jon.recoil.org
this repo has no description
1open Component
2
3exception Invalidated
4
5type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b
6
7type 'a type_or_replaced = ('a, TypeExpr.t * TypeDecl.Equation.t) or_replaced
8
9type 'a module_type_or_replaced = ('a, ModuleType.expr) or_replaced
10
11let map_replaced f = function
12 | Not_replaced p -> Not_replaced (f p)
13 | Replaced _ as r -> r
14
15open Component
16open Substitution
17
18type nonrec t = t
19
20let identity =
21 {
22 module_ = ModuleMap.empty;
23 module_type = ModuleTypeMap.empty;
24 module_type_replacement = ModuleTypeMap.empty;
25 type_ = TypeMap.empty;
26 class_type = TypeMap.empty;
27 type_replacement = TypeMap.empty;
28 path_invalidating_modules = [];
29 unresolve_opaque_paths = false;
30 }
31
32let pp fmt s =
33 let pp_map pp_binding b fmt map =
34 let pp_b fmt (id, v) =
35 Format.fprintf fmt "%a -> %a" Ident.fmt id pp_binding v
36 in
37 Format.fprintf fmt "@[<hov 1>{%a}@]" (Format.pp_print_list pp_b) (b map)
38 in
39 let pp_subst ppp fmt v =
40 Format.fprintf fmt "%s"
41 (match v with
42 | `Prefixed (p, _) -> Format.asprintf "%a" ppp p
43 | `Renamed id' -> Format.asprintf "%a" Ident.fmt id'
44 | `Substituted -> "<substituted>")
45 in
46 let pp_type_replacement fmt (te, eq) =
47 Format.fprintf fmt "(%a,%a)"
48 Component.Fmt.(type_expr default)
49 te
50 Component.Fmt.(type_equation default)
51 eq
52 in
53
54 Format.fprintf fmt
55 "{ module_ = %a;@ module_type = %a;@ type_ = %a;@ class_type = %a;@ \
56 type_replacement = %a;@ module_type_replacement = %a;@ \
57 path_invalidating_modules = [%a];@ unresolve_opaque_paths = %b }"
58 (pp_map (pp_subst Component.Fmt.(module_path default)) ModuleMap.bindings)
59 s.module_
60 (pp_map
61 (pp_subst Component.Fmt.(module_type_path default))
62 ModuleTypeMap.bindings)
63 s.module_type
64 (pp_map (pp_subst Component.Fmt.(type_path default)) TypeMap.bindings)
65 s.type_
66 (pp_map (pp_subst Component.Fmt.(class_type_path default)) TypeMap.bindings)
67 s.class_type
68 (pp_map pp_type_replacement TypeMap.bindings)
69 s.type_replacement
70 (pp_map Component.Fmt.(module_type_expr default) ModuleTypeMap.bindings)
71 s.module_type_replacement
72 (Format.pp_print_list Ident.fmt)
73 s.path_invalidating_modules s.unresolve_opaque_paths
74
75let unresolve_opaque_paths s = { s with unresolve_opaque_paths = true }
76
77let path_invalidate_module id t =
78 { t with path_invalidating_modules = id :: t.path_invalidating_modules }
79
80let add_module id p rp t =
81 { t with module_ = ModuleMap.add id (`Prefixed (p, rp)) t.module_ }
82
83let add_module_type id p rp t =
84 {
85 t with
86 module_type = ModuleTypeMap.add id (`Prefixed (p, rp)) t.module_type;
87 }
88
89let add_type : Ident.type_ -> Cpath.type_ -> Cpath.Resolved.type_ -> t -> t =
90 fun id p rp t ->
91 { t with type_ = TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.type_ }
92
93let add_class :
94 Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t =
95 fun id p rp t ->
96 {
97 t with
98 type_ =
99 TypeMap.add
100 (id :> Ident.type_)
101 (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_)))
102 t.type_;
103 class_type =
104 TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type;
105 }
106
107let add_class_type :
108 Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t =
109 fun id p rp t ->
110 {
111 t with
112 type_ =
113 TypeMap.add
114 (id :> Ident.type_)
115 (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_)))
116 t.type_;
117 class_type =
118 TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type;
119 }
120
121let add_type_replacement id texp equation t =
122 {
123 t with
124 type_replacement = TypeMap.add id (texp, equation) t.type_replacement;
125 }
126
127let add_module_type_replacement path mty t =
128 {
129 t with
130 module_type_replacement =
131 ModuleTypeMap.add path mty t.module_type_replacement;
132 }
133
134let add_module_substitution : Ident.module_ -> t -> t =
135 fun id t ->
136 {
137 t with
138 path_invalidating_modules = id :: t.path_invalidating_modules;
139 module_ = ModuleMap.add id `Substituted t.module_;
140 }
141
142let rename_module : Ident.module_ -> Ident.module_ -> t -> t =
143 fun id id' t -> { t with module_ = ModuleMap.add id (`Renamed id') t.module_ }
144
145let rename_module_type : Ident.module_type -> Ident.module_type -> t -> t =
146 fun id id' t ->
147 { t with module_type = ModuleTypeMap.add id (`Renamed id') t.module_type }
148
149let rename_type : Ident.type_ -> Ident.type_ -> t -> t =
150 fun id id' t -> { t with type_ = TypeMap.add id (`Renamed id') t.type_ }
151
152let rename_class_type : Ident.type_ -> Ident.type_ -> t -> t =
153 fun id id' t ->
154 {
155 t with
156 class_type = TypeMap.add id (`Renamed id') t.class_type;
157 type_ =
158 TypeMap.add (id :> Ident.type_) (`Renamed (id' :> Ident.type_)) t.type_;
159 }
160
161let rec substitute_vars vars t =
162 let open TypeExpr in
163 match t with
164 | Var (s, _jk) -> ( try List.assoc s vars with Not_found -> t)
165 | Any -> Any
166 | Alias (t, str) -> Alias (substitute_vars vars t, str)
167 | Arrow (lbl, t1, t2, modes, ret_modes) ->
168 Arrow (lbl, substitute_vars vars t1, substitute_vars vars t2, modes, ret_modes)
169 | Tuple ts ->
170 Tuple (List.map (fun (lbl, ty) -> (lbl, substitute_vars vars ty)) ts)
171 | Unboxed_tuple ts ->
172 Unboxed_tuple (List.map (fun (l, t) -> l, substitute_vars vars t) ts)
173 | Constr (p, ts) -> Constr (p, List.map (substitute_vars vars) ts)
174 | Polymorphic_variant v ->
175 Polymorphic_variant (substitute_vars_poly_variant vars v)
176 | Object o -> Object (substitute_vars_type_object vars o)
177 | Class (p, ts) -> Class (p, List.map (substitute_vars vars) ts)
178 | Poly (strs, ts) -> Poly (strs, substitute_vars vars ts)
179 | Quote t -> Quote (substitute_vars vars t)
180 | Splice t -> Splice (substitute_vars vars t)
181 | Package p -> Package (substitute_vars_package vars p)
182
183and substitute_vars_package vars p =
184 let open TypeExpr.Package in
185 let subst_subst (p, t) = (p, substitute_vars vars t) in
186 { p with substitutions = List.map subst_subst p.substitutions }
187
188and substitute_vars_type_object vars o =
189 let open TypeExpr.Object in
190 let subst_field = function
191 | Method m -> Method { m with type_ = substitute_vars vars m.type_ }
192 | Inherit t -> Inherit (substitute_vars vars t)
193 in
194 { o with fields = List.map subst_field o.fields }
195
196and substitute_vars_poly_variant vars v =
197 let open TypeExpr.Polymorphic_variant in
198 let subst_element = function
199 | Type t -> Type (substitute_vars vars t)
200 | Constructor c ->
201 let arguments =
202 List.map (substitute_vars vars) c.Constructor.arguments
203 in
204 Constructor { c with arguments }
205 in
206 { v with elements = List.map subst_element v.elements }
207
208let rec resolved_module_path :
209 t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ =
210 fun s p ->
211 match p with
212 | `Local id -> (
213 if List.mem id s.path_invalidating_modules then raise Invalidated;
214 match
215 try Some (ModuleMap.find (id :> Ident.module_) s.module_)
216 with _ -> None
217 with
218 | Some (`Renamed x) -> `Local x
219 | Some (`Prefixed (_p, rp)) -> rp
220 | Some `Substituted -> `Substituted p
221 | None -> p)
222 | `Gpath _ -> p
223 | `Apply (p1, p2) ->
224 `Apply (resolved_module_path s p1, resolved_module_path s p2)
225 | `Substituted p -> `Substituted (resolved_module_path s p)
226 | `Module (p, n) -> `Module (resolved_parent_path s p, n)
227 | `Alias (p1, p2, p3opt) ->
228 let p2' = module_path s p2 in
229 let up2' = try Cpath.unresolve_module_path p2' with _ -> p2' in
230 let p3opt' =
231 match p3opt with
232 | Some p3 -> Some (resolved_module_path s p3)
233 | None -> None
234 in
235 `Alias (resolved_module_path s p1, up2', p3opt')
236 | `Subst (p1, p2) ->
237 let p1 =
238 match resolved_module_type_path s p1 with
239 | Replaced _ ->
240 (* the left hand side of Subst is a named module type inside a module,
241 it cannot be substituted away *)
242 assert false
243 | Not_replaced p1 -> p1
244 in
245 `Subst (p1, resolved_module_path s p2)
246 | `Hidden p1 -> `Hidden (resolved_module_path s p1)
247 | `Canonical (p1, p2) -> `Canonical (resolved_module_path s p1, p2)
248 | `OpaqueModule m ->
249 if s.unresolve_opaque_paths then raise Invalidated
250 else `OpaqueModule (resolved_module_path s m)
251
252and resolved_parent_path s = function
253 | `Module m -> `Module (resolved_module_path s m)
254 | `ModuleType m ->
255 let p =
256 match resolved_module_type_path s m with
257 | Replaced _ -> assert false
258 | Not_replaced p1 -> p1
259 in
260 `ModuleType p
261 | `FragmentRoot as x -> x
262
263and module_path : t -> Cpath.module_ -> Cpath.module_ =
264 fun s p ->
265 match p with
266 | `Resolved p' -> (
267 try `Resolved (resolved_module_path s p')
268 with Invalidated ->
269 let path' = Cpath.unresolve_resolved_module_path p' in
270 module_path s path')
271 | `Dot (p', str) -> `Dot (module_path s p', str)
272 | `Module (p', str) -> `Module (resolved_parent_path s p', str)
273 | `Apply (p1, p2) -> `Apply (module_path s p1, module_path s p2)
274 | `Local (id, b) -> (
275 match
276 try Some (ModuleMap.find (id :> Ident.module_) s.module_)
277 with _ -> None
278 with
279 | Some (`Prefixed (p, _rp)) -> p
280 | Some (`Renamed x) -> `Local (x, b)
281 | Some `Substituted -> `Substituted p
282 | None -> `Local (id, b))
283 | `Identifier _ -> p
284 | `Substituted p -> `Substituted (module_path s p)
285 | `Forward _ -> p
286 | `Root _ -> p
287
288and resolved_module_type_path :
289 t ->
290 Cpath.Resolved.module_type ->
291 (Cpath.Resolved.module_type, ModuleType.expr) or_replaced =
292 fun s p ->
293 match p with
294 | `Local id -> (
295 if ModuleTypeMap.mem id s.module_type_replacement then
296 Replaced (ModuleTypeMap.find id s.module_type_replacement)
297 else
298 match ModuleTypeMap.find id s.module_type with
299 | `Prefixed (_p, rp) -> Not_replaced rp
300 | `Renamed x -> Not_replaced (`Local x)
301 | exception Not_found -> Not_replaced (`Local id))
302 | `Gpath _ -> Not_replaced p
303 | `Substituted p ->
304 resolved_module_type_path s p |> map_replaced (fun p -> `Substituted p)
305 | `ModuleType (p, n) ->
306 Not_replaced (`ModuleType (resolved_parent_path s p, n))
307 | `CanonicalModuleType (mt1, mt2) -> (
308 match resolved_module_type_path s mt1 with
309 | Not_replaced mt1' -> Not_replaced (`CanonicalModuleType (mt1', mt2))
310 | x -> x)
311 | `OpaqueModuleType m ->
312 if s.unresolve_opaque_paths then raise Invalidated
313 else
314 resolved_module_type_path s m
315 |> map_replaced (fun x -> `OpaqueModuleType x)
316 | `SubstT (p1, p2) -> (
317 match
318 (resolved_module_type_path s p1, resolved_module_type_path s p2)
319 with
320 | Not_replaced p1, Not_replaced p2 -> Not_replaced (`SubstT (p1, p2))
321 | Replaced mt, _ | _, Replaced mt -> Replaced mt)
322 | `AliasModuleType (p1, p2) -> (
323 match
324 (resolved_module_type_path s p1, resolved_module_type_path s p2)
325 with
326 | Not_replaced p1, Not_replaced p2 ->
327 Not_replaced (`AliasModuleType (p1, p2))
328 | Replaced mt, _ | _, Replaced mt -> Replaced mt)
329
330and module_type_path :
331 t -> Cpath.module_type -> Cpath.module_type module_type_or_replaced =
332 fun s p ->
333 match p with
334 | `Resolved r -> (
335 try resolved_module_type_path s r |> map_replaced (fun r -> `Resolved r)
336 with Invalidated ->
337 let path' = Cpath.unresolve_resolved_module_type_path r in
338 module_type_path s path')
339 | `Substituted p ->
340 module_type_path s p |> map_replaced (fun r -> `Substituted r)
341 | `Local (id, b) ->
342 if ModuleTypeMap.mem id s.module_type_replacement then
343 Replaced (ModuleTypeMap.find id s.module_type_replacement)
344 else
345 let r =
346 match
347 try Some (ModuleTypeMap.find id s.module_type) with _ -> None
348 with
349 | Some (`Prefixed (p, _rp)) -> p
350 | Some (`Renamed x) -> `Local (x, b)
351 | None -> `Local (id, b)
352 in
353 Not_replaced r
354 | `Identifier _ -> Not_replaced p
355 | `DotMT (p, n) -> Not_replaced (`DotMT (module_path s p, n))
356 | `ModuleType (p', str) ->
357 Not_replaced (`ModuleType (resolved_parent_path s p', str))
358
359and resolved_type_path :
360 t ->
361 Cpath.Resolved.type_ ->
362 (Cpath.Resolved.type_, TypeExpr.t * TypeDecl.Equation.t) or_replaced =
363 fun s p ->
364 match p with
365 | `CoreType _ as c -> Not_replaced c
366 | `Local id -> (
367 if TypeMap.mem id s.type_replacement then
368 Replaced (TypeMap.find id s.type_replacement)
369 else
370 match try Some (TypeMap.find id s.type_) with Not_found -> None with
371 | Some (`Prefixed (_p, rp)) -> Not_replaced rp
372 | Some (`Renamed x) -> Not_replaced (`Local x)
373 | None -> Not_replaced (`Local id))
374 | `CanonicalType (t1, t2) -> (
375 match resolved_type_path s t1 with
376 | Not_replaced t1' -> Not_replaced (`CanonicalType (t1', t2))
377 | x -> x)
378 | `Gpath _ -> Not_replaced p
379 | `Substituted p ->
380 resolved_type_path s p |> map_replaced (fun p -> `Substituted p)
381 | `Type (p, n) -> Not_replaced (`Type (resolved_parent_path s p, n))
382 | `ClassType (p, n) -> Not_replaced (`ClassType (resolved_parent_path s p, n))
383 | `Class (p, n) -> Not_replaced (`Class (resolved_parent_path s p, n))
384
385and type_path : t -> Cpath.type_ -> Cpath.type_ type_or_replaced =
386 fun s p ->
387 match p with
388 | `Resolved r -> (
389 try resolved_type_path s r |> map_replaced (fun r -> `Resolved r)
390 with Invalidated ->
391 let path' = Cpath.unresolve_resolved_type_path r in
392 type_path s path')
393 | `Substituted p -> type_path s p |> map_replaced (fun r -> `Substituted r)
394 | `Local (id, b) -> (
395 if TypeMap.mem id s.type_replacement then
396 Replaced (TypeMap.find id s.type_replacement)
397 else
398 match try Some (TypeMap.find id s.type_) with Not_found -> None with
399 | Some (`Prefixed (p, _rp)) -> Not_replaced p
400 | Some (`Renamed x) -> Not_replaced (`Local (x, b))
401 | None -> Not_replaced (`Local (id, b)))
402 | `Identifier _ -> Not_replaced p
403 | `DotT (p, n) -> Not_replaced (`DotT (module_path s p, n))
404 | `Type (p, n) -> Not_replaced (`Type (resolved_parent_path s p, n))
405 | `Class (p, n) -> Not_replaced (`Class (resolved_parent_path s p, n))
406 | `ClassType (p, n) -> Not_replaced (`ClassType (resolved_parent_path s p, n))
407
408and resolved_class_type_path :
409 t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type =
410 fun s p ->
411 match p with
412 | `Local id -> (
413 match try Some (TypeMap.find id s.class_type) with _ -> None with
414 | Some (`Prefixed (_p, rp)) -> rp
415 | Some (`Renamed x) -> `Local x
416 | None -> `Local id)
417 | `Gpath _ -> p
418 | `Substituted p -> `Substituted (resolved_class_type_path s p)
419 | `ClassType (p, n) -> `ClassType (resolved_parent_path s p, n)
420 | `Class (p, n) -> `Class (resolved_parent_path s p, n)
421
422and class_type_path : t -> Cpath.class_type -> Cpath.class_type =
423 fun s p ->
424 match p with
425 | `Resolved r -> (
426 try `Resolved (resolved_class_type_path s r)
427 with Invalidated ->
428 let path' = Cpath.unresolve_resolved_class_type_path r in
429 class_type_path s path')
430 | `Local (id, b) -> (
431 match try Some (TypeMap.find id s.class_type) with _ -> None with
432 | Some (`Prefixed (p, _rp)) -> p
433 | Some (`Renamed x) -> `Local (x, b)
434 | None -> `Local (id, b))
435 | `Identifier _ -> p
436 | `Substituted p -> `Substituted (class_type_path s p)
437 | `DotT (p, n) -> `DotT (module_path s p, n)
438 | `Class (p, n) -> `Class (resolved_parent_path s p, n)
439 | `ClassType (p, n) -> `ClassType (resolved_parent_path s p, n)
440
441let rec resolved_signature_fragment :
442 t -> Cfrag.resolved_signature -> Cfrag.resolved_signature =
443 fun t r ->
444 match r with
445 | `Root (`ModuleType p) ->
446 let p =
447 match resolved_module_type_path t p with
448 | Not_replaced p -> p
449 | Replaced _ ->
450 (* The module type path was replaced by an expression. We can't keep
451 it as a resolved fragment, so raise Invalidated to trigger
452 unresolving. This can happen with OxCaml mode types. *)
453 raise Invalidated
454 in
455 `Root (`ModuleType p)
456 | `Root (`Module p) -> `Root (`Module (resolved_module_path t p))
457 | (`Subst _ | `Alias _ | `OpaqueModule _ | `Module _) as x ->
458 (resolved_module_fragment t x :> Cfrag.resolved_signature)
459
460and resolved_module_fragment :
461 t -> Cfrag.resolved_module -> Cfrag.resolved_module =
462 fun t r ->
463 match r with
464 | `Subst (mty, f) ->
465 let p =
466 match resolved_module_type_path t mty with
467 | Not_replaced p -> p
468 | Replaced _ ->
469 (* the left hand side of subst is a named module type inside a module,
470 it cannot be substituted *)
471 assert false
472 in
473 `Subst (p, resolved_module_fragment t f)
474 | `Alias (m, f) ->
475 `Alias (resolved_module_path t m, resolved_module_fragment t f)
476 | `Module (sg, n) -> `Module (resolved_signature_fragment t sg, n)
477 | `OpaqueModule m -> `OpaqueModule (resolved_module_fragment t m)
478
479and resolved_module_type_fragment :
480 t -> Cfrag.resolved_module_type -> Cfrag.resolved_module_type =
481 fun t r ->
482 match r with
483 | `ModuleType (s, n) -> `ModuleType (resolved_signature_fragment t s, n)
484
485and resolved_type_fragment : t -> Cfrag.resolved_type -> Cfrag.resolved_type =
486 fun t r ->
487 match r with
488 | `Type (s, n) -> `Type (resolved_signature_fragment t s, n)
489 | `ClassType (s, n) -> `ClassType (resolved_signature_fragment t s, n)
490 | `Class (s, n) -> `Class (resolved_signature_fragment t s, n)
491
492let rec signature_fragment : t -> Cfrag.signature -> Cfrag.signature =
493 fun t r ->
494 match r with
495 | `Resolved f -> (
496 try `Resolved (resolved_signature_fragment t f)
497 with Invalidated ->
498 let frag' = Cfrag.unresolve_signature f in
499 signature_fragment t frag')
500 | `Dot (sg, n) -> `Dot (signature_fragment t sg, n)
501 | `Root -> `Root
502
503let rec module_fragment : t -> Cfrag.module_ -> Cfrag.module_ =
504 fun t r ->
505 match r with
506 | `Resolved r -> (
507 try `Resolved (resolved_module_fragment t r)
508 with Invalidated ->
509 let frag' = Cfrag.unresolve_module r in
510 module_fragment t frag')
511 | `Dot (sg, n) -> `Dot (signature_fragment t sg, n)
512
513let rec module_type_fragment : t -> Cfrag.module_type -> Cfrag.module_type =
514 fun t r ->
515 match r with
516 | `Resolved r -> (
517 try `Resolved (resolved_module_type_fragment t r)
518 with Invalidated ->
519 let frag' = Cfrag.unresolve_module_type r in
520 module_type_fragment t frag')
521 | `Dot (sg, n) -> `Dot (signature_fragment t sg, n)
522
523let rec type_fragment : t -> Cfrag.type_ -> Cfrag.type_ =
524 fun t r ->
525 match r with
526 | `Resolved r -> (
527 try `Resolved (resolved_type_fragment t r)
528 with Invalidated ->
529 let frag' = Cfrag.unresolve_type r in
530 type_fragment t frag')
531 | `Dot (sg, n) -> `Dot (signature_fragment t sg, n)
532
533let option_ conv s x = match x with Some x -> Some (conv s x) | None -> None
534
535let list conv s xs = List.map (conv s) xs
536
537let rec type_ s t =
538 let open Component.TypeDecl in
539 let representation = option_ type_decl_representation s t.representation in
540 { t with equation = type_decl_equation s t.equation; representation }
541
542and type_decl_representation s t =
543 let open Component.TypeDecl.Representation in
544 match t with
545 | Variant cs -> Variant (List.map (type_decl_constructor s) cs)
546 | Record fs -> Record (List.map (type_decl_field s) fs)
547 | Record_unboxed_product fs ->
548 Record_unboxed_product (List.map (type_decl_unboxed_field s) fs)
549 | Extensible -> t
550
551and type_decl_constructor s t =
552 let open Component.TypeDecl.Constructor in
553 let args = type_decl_constructor_arg s t.args in
554 let res = option_ type_expr s t.res in
555 { t with args; res }
556
557and type_poly_var s v =
558 let open Component.TypeExpr.Polymorphic_variant in
559 let map_constr c =
560 let open Constructor in
561 {
562 name = c.name;
563 constant = c.constant;
564 arguments = List.map (type_expr s) c.arguments;
565 doc = c.doc;
566 }
567 in
568 let map_element = function
569 | Type t -> (
570 match type_expr s t with
571 | Polymorphic_variant v -> v.elements
572 | x -> [ Type x ])
573 | Constructor c -> [ Constructor (map_constr c) ]
574 in
575
576 { kind = v.kind; elements = List.flatten (List.map map_element v.elements) }
577
578and type_object s o =
579 let open Component.TypeExpr.Object in
580 let map_field = function
581 | Method m -> Method { m with type_ = type_expr s m.type_ }
582 | Inherit t -> Inherit (type_expr s t)
583 in
584 { fields = List.map map_field o.fields; open_ = o.open_ }
585
586and type_package s p =
587 let open Component.TypeExpr.Package in
588 let sub (x, y) = (type_fragment s x, type_expr s y) in
589 {
590 path =
591 (match module_type_path s p.path with
592 | Not_replaced p -> p
593 | Replaced (Path p) -> p.p_path
594 | Replaced _ ->
595 (* substituting away a packed module type by a non-path module type is a type error *)
596 assert false);
597 substitutions = List.map sub p.substitutions;
598 }
599
600and type_expr s t =
601 let open Component.TypeExpr in
602 match t with
603 | Var _ as v -> v
604 | Any -> Any
605 | Alias (t, str) -> Alias (type_expr s t, str)
606 | Arrow (lbl, t1, t2, modes, ret_modes) -> Arrow (lbl, type_expr s t1, type_expr s t2, modes, ret_modes)
607 | Tuple ts -> Tuple (List.map (fun (lbl, ty) -> (lbl, type_expr s ty)) ts)
608 | Unboxed_tuple ts -> Unboxed_tuple (List.map (fun (l, t) -> l, type_expr s t) ts)
609 | Constr (p, ts) -> (
610 match type_path s p with
611 | Replaced (t, eq) ->
612 let mk_var acc pexpr param =
613 match param.Odoc_model.Lang.TypeDecl.desc with
614 | Any -> acc
615 | Var (n, _) -> (n, type_expr s pexpr) :: acc
616 in
617 if List.length ts <> List.length eq.params then (
618 Format.eprintf
619 "Type substitution error: eq.params length=%d ts length=%d@."
620 (List.length eq.params) (List.length ts);
621 assert false);
622 let vars = List.fold_left2 mk_var [] ts eq.params in
623 substitute_vars vars t
624 | Not_replaced p -> Constr (p, List.map (type_expr s) ts))
625 | Polymorphic_variant v -> Polymorphic_variant (type_poly_var s v)
626 | Object o -> Object (type_object s o)
627 | Class (p, ts) -> Class (class_type_path s p, List.map (type_expr s) ts)
628 | Poly (strs, ts) -> Poly (strs, type_expr s ts)
629 | Quote t -> Quote (type_expr s t)
630 | Splice t -> Splice (type_expr s t)
631 | Package p -> Package (type_package s p)
632
633and simple_expansion :
634 t ->
635 Component.ModuleType.simple_expansion ->
636 Component.ModuleType.simple_expansion =
637 fun s t ->
638 let open Component.ModuleType in
639 match t with
640 | Signature sg -> Signature (signature s sg)
641 | Functor (arg, sg) -> Functor (functor_parameter s arg, simple_expansion s sg)
642
643and module_type s t =
644 let open Component.ModuleType in
645 let expr =
646 match t.expr with Some m -> Some (module_type_expr s m) | None -> None
647 in
648 { expr; source_loc = t.source_loc; source_loc_jane = t.source_loc_jane ; doc = t.doc; canonical = t.canonical }
649
650and module_type_substitution s t =
651 let open Component.ModuleTypeSubstitution in
652 let manifest = module_type_expr s t.manifest in
653 { manifest; doc = t.doc }
654
655and functor_parameter s t =
656 let open Component.FunctorParameter in
657 match t with
658 | Named arg -> Named { arg with expr = module_type_expr s arg.expr }
659 | Unit -> Unit
660
661and module_type_type_of_desc s t =
662 let open Component.ModuleType in
663 match t with
664 | ModPath p -> ModPath (module_path s p)
665 | StructInclude p -> StructInclude (module_path s p)
666
667and u_module_type_expr s t =
668 let open Component.ModuleType.U in
669 match t with
670 | Path p -> (
671 match module_type_path s p with
672 | Not_replaced p -> Path p
673 | Replaced eqn -> (
674 match eqn with
675 | Path p -> Path p.p_path
676 | Signature s -> Signature s
677 | TypeOf t -> TypeOf (t.t_desc, t.t_original_path)
678 | With w -> With (w.w_substitutions, w.w_expr)
679 | Functor _ ->
680 (* non functor cannot be substituted away to a functor *)
681 assert false
682 | Strengthen s -> Strengthen (s.s_expr, s.s_path, s.s_aliasable)))
683 | Signature sg -> Signature (signature s sg)
684 | With (subs, e) ->
685 With
686 (List.map (with_module_type_substitution s) subs, u_module_type_expr s e)
687 | TypeOf (t_desc, t_original_path) ->
688 TypeOf (module_type_type_of_desc s t_desc, t_original_path)
689 | Strengthen (expr, path, aliasable) ->
690 let expr = u_module_type_expr s expr in
691 let path = module_path s path in
692 Strengthen (expr, path, aliasable)
693
694and module_type_expr s t =
695 let open Component.ModuleType in
696 match t with
697 | Path { p_path; p_expansion } -> (
698 match module_type_path s p_path with
699 | Not_replaced p_path ->
700 Path { p_path; p_expansion = option_ simple_expansion s p_expansion }
701 | Replaced s -> s)
702 | Signature sg -> Signature (signature s sg)
703 | Functor (arg, expr) ->
704 Functor (functor_parameter s arg, module_type_expr s expr)
705 | With { w_substitutions; w_expansion; w_expr } ->
706 With
707 {
708 w_substitutions =
709 List.map (with_module_type_substitution s) w_substitutions;
710 w_expansion = option_ simple_expansion s w_expansion;
711 w_expr = u_module_type_expr s w_expr;
712 }
713 | TypeOf t ->
714 TypeOf
715 {
716 t with
717 t_desc = module_type_type_of_desc s t.t_desc;
718 t_expansion = option_ simple_expansion s t.t_expansion;
719 }
720 | Strengthen { s_expr; s_path; s_aliasable; s_expansion } ->
721 Strengthen
722 {
723 s_expr = u_module_type_expr s s_expr;
724 s_path = module_path s s_path;
725 s_aliasable;
726 s_expansion = option_ simple_expansion s s_expansion
727 }
728
729and with_module_type_substitution s sub =
730 let open Component.ModuleType in
731 match sub with
732 | ModuleEq (f, m) -> ModuleEq (module_fragment s f, module_decl s m)
733 | ModuleSubst (f, p) -> ModuleSubst (module_fragment s f, module_path s p)
734 | TypeEq (f, eq) -> TypeEq (type_fragment s f, type_decl_equation s eq)
735 | TypeSubst (f, eq) -> TypeSubst (type_fragment s f, type_decl_equation s eq)
736 | ModuleTypeEq (f, eq) ->
737 ModuleTypeEq (module_type_fragment s f, module_type_expr s eq)
738 | ModuleTypeSubst (f, eq) ->
739 ModuleTypeSubst (module_type_fragment s f, module_type_expr s eq)
740
741and module_decl s t =
742 match t with
743 | Alias (p, e) -> Alias (module_path s p, option_ simple_expansion s e)
744 | ModuleType t -> ModuleType (module_type_expr s t)
745
746and include_decl s t =
747 match t with
748 | Include.Alias p -> Include.Alias (module_path s p)
749 | ModuleType t -> ModuleType (u_module_type_expr s t)
750
751and module_ s t =
752 let open Component.Module in
753 let type_ = module_decl s t.type_ in
754 let canonical = t.canonical in
755 { t with type_; canonical }
756
757and module_substitution s m =
758 let open Component.ModuleSubstitution in
759 let manifest = module_path s m.manifest in
760 { manifest; doc = m.doc }
761
762and type_decl_field s f =
763 let open Component.TypeDecl.Field in
764 { f with type_ = type_expr s f.type_ }
765
766and type_decl_unboxed_field s f =
767 let open Component.TypeDecl.UnboxedField in
768 { f with type_ = type_expr s f.type_ }
769
770and type_decl_constructor_arg s a =
771 let open Component.TypeDecl.Constructor in
772 match a with
773 | Tuple ts -> Tuple (list type_expr s ts)
774 | Record fs -> Record (list type_decl_field s fs)
775
776and type_decl_equation s t =
777 let open Component.TypeDecl.Equation in
778 {
779 t with
780 manifest = option_ type_expr s t.manifest;
781 constraints =
782 List.map (fun (x, y) -> (type_expr s x, type_expr s y)) t.constraints;
783 }
784
785and exception_ s e =
786 let open Component.Exception in
787 let res = option_ type_expr s e.res in
788 let args = type_decl_constructor_arg s e.args in
789 { e with args; res }
790
791and extension_constructor s c =
792 let open Component.Extension.Constructor in
793 {
794 c with
795 args = type_decl_constructor_arg s c.args;
796 res = option_ type_expr s c.res;
797 }
798
799and extension s e =
800 let open Component.Extension in
801 let type_path =
802 match type_path s e.type_path with
803 | Not_replaced p -> p
804 | Replaced (TypeExpr.Constr (p, _), _) -> p
805 | Replaced _ -> (* What else is possible ? *) assert false
806 and constructors = List.map (extension_constructor s) e.constructors in
807 { e with type_path; constructors }
808
809and include_ s i =
810 let open Component.Include in
811 {
812 i with
813 decl = include_decl s i.decl;
814 strengthened = option_ module_path s i.strengthened;
815 expansion_ = apply_sig_map_sg s i.expansion_;
816 }
817
818and open_ s o =
819 let open Component.Open in
820 { expansion = apply_sig_map_sg s o.expansion; doc = o.doc }
821
822and value s v =
823 let open Component.Value in
824 { v with type_ = type_expr s v.type_ }
825
826and class_ s c =
827 let open Component.Class in
828 let expansion = option_ class_signature s c.expansion in
829 { c with type_ = class_decl s c.type_; expansion }
830
831and class_decl s =
832 let open Component.Class in
833 function
834 | ClassType e -> ClassType (class_type_expr s e)
835 | Arrow (lbl, t, d) -> Arrow (lbl, type_expr s t, class_decl s d)
836
837and class_type_expr s =
838 let open Component.ClassType in
839 function
840 | Constr (p, ts) -> Constr (class_type_path s p, List.map (type_expr s) ts)
841 | Signature sg -> Signature (class_signature s sg)
842
843and class_type s c =
844 let open Component.ClassType in
845 let expansion = option_ class_signature s c.expansion in
846 { c with expr = class_type_expr s c.expr; expansion }
847
848and class_signature_item s =
849 let open Component.ClassSignature in
850 function
851 | Method (id, m) -> Method (id, method_ s m)
852 | InstanceVariable (id, i) -> InstanceVariable (id, instance_variable s i)
853 | Constraint cst -> Constraint (class_constraint s cst)
854 | Inherit e -> Inherit (inherit_ s e)
855 | Comment _ as y -> y
856
857and class_signature s sg =
858 let open Component.ClassSignature in
859 {
860 sg with
861 self = option_ type_expr s sg.self;
862 items = List.map (class_signature_item s) sg.items;
863 }
864
865and method_ s m =
866 let open Component.Method in
867 { m with type_ = type_expr s m.type_ }
868
869and instance_variable s i =
870 let open Component.InstanceVariable in
871 { i with type_ = type_expr s i.type_ }
872
873and class_constraint s cst =
874 let open Component.ClassSignature.Constraint in
875 { cst with left = type_expr s cst.left; right = type_expr s cst.right }
876
877and inherit_ s ih =
878 let open Component.ClassSignature.Inherit in
879 { ih with expr = class_type_expr s ih.expr }
880
881and rename_bound_idents s sg =
882 let open Component.Signature in
883 let new_module_id id =
884 try
885 match ModuleMap.find (id :> Ident.module_) s.module_ with
886 | `Renamed (`LModule _ as x) -> x
887 | `Prefixed (_, _) ->
888 (* This is unusual but can happen when we have TypeOf expressions. It means
889 we're already prefixing this module path, hence we can essentially rename
890 it to whatever we like because it's never going to be referred to. *)
891 Ident.Rename.module_ id
892 | _ -> failwith "Error"
893 with Not_found -> Ident.Rename.module_ id
894 in
895 let new_module_type_id id =
896 try
897 match ModuleTypeMap.find id s.module_type with
898 | `Renamed x -> x
899 | `Prefixed (_, _) -> Ident.Rename.module_type id
900 with Not_found -> Ident.Rename.module_type id
901 in
902 let new_type_id id =
903 try
904 match TypeMap.find (id :> Ident.type_) s.type_ with
905 | `Renamed (`LType _ as x) -> x
906 | `Prefixed (_, _) -> Ident.Rename.type_ id
907 with Not_found -> Ident.Rename.type_ id
908 in
909 let new_class_id id =
910 try
911 match TypeMap.find (id :> Ident.type_) s.class_type with
912 | `Renamed (`LType _ as x) -> x
913 | `Prefixed (_, _) -> Ident.Rename.type_ id
914 with Not_found -> Ident.Rename.type_ id
915 in
916 let new_class_type_id id =
917 try
918 match TypeMap.find (id :> Ident.type_) s.class_type with
919 | `Renamed (`LType _ as x) -> x
920 | `Prefixed (_, _) -> Ident.Rename.type_ id
921 with Not_found -> Ident.Rename.type_ id
922 in
923 function
924 | [] -> (s, List.rev sg)
925 | Module (id, r, m) :: rest ->
926 let id' = new_module_id id in
927 rename_bound_idents
928 (rename_module (id :> Ident.module_) (id' :> Ident.module_) s)
929 (Module (id', r, m) :: sg)
930 rest
931 | ModuleSubstitution (id, m) :: rest ->
932 let id' = new_module_id id in
933 rename_bound_idents
934 (rename_module (id :> Ident.module_) (id' :> Ident.module_) s)
935 (ModuleSubstitution (id', m) :: sg)
936 rest
937 | ModuleType (id, mt) :: rest ->
938 let id' = new_module_type_id id in
939 rename_bound_idents
940 (rename_module_type id id' s)
941 (ModuleType (id', mt) :: sg)
942 rest
943 | ModuleTypeSubstitution (id, mt) :: rest ->
944 let id' = new_module_type_id id in
945 rename_bound_idents
946 (rename_module_type id id' s)
947 (ModuleTypeSubstitution (id', mt) :: sg)
948 rest
949 | Type (id, r, t) :: rest ->
950 let id' = new_type_id id in
951 rename_bound_idents
952 (rename_type (id :> Ident.type_) (id' :> Ident.type_) s)
953 (Type (id', r, t) :: sg)
954 rest
955 | TypeSubstitution (id, t) :: rest ->
956 let id' = new_type_id id in
957 rename_bound_idents
958 (rename_type (id :> Ident.type_) (id' :> Ident.type_) s)
959 (TypeSubstitution (id', t) :: sg)
960 rest
961 | Exception (id, e) :: rest ->
962 let id' = Ident.Rename.exception_ id in
963 rename_bound_idents s (Exception (id', e) :: sg) rest
964 | TypExt e :: rest -> rename_bound_idents s (TypExt e :: sg) rest
965 | Value (id, v) :: rest ->
966 let id' = Ident.Rename.value id in
967 rename_bound_idents s (Value (id', v) :: sg) rest
968 | Class (id, r, c) :: rest ->
969 let id' = new_class_id id in
970 rename_bound_idents
971 (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s)
972 (Class (id', r, c) :: sg)
973 rest
974 | ClassType (id, r, c) :: rest ->
975 let id' = new_class_type_id id in
976 rename_bound_idents
977 (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s)
978 (ClassType (id', r, c) :: sg)
979 rest
980 | Include ({ expansion_; _ } as i) :: rest ->
981 let s, items = rename_bound_idents s [] expansion_.items in
982 rename_bound_idents s
983 (Include { i with expansion_ = { expansion_ with items; removed = [] } }
984 :: sg)
985 rest
986 | Open { expansion; doc } :: rest ->
987 let s, items = rename_bound_idents s [] expansion.items in
988 rename_bound_idents s
989 (Open { expansion = { expansion with items; removed = [] }; doc } :: sg)
990 rest
991 | (Comment _ as item) :: rest -> rename_bound_idents s (item :: sg) rest
992
993and removed_items s items =
994 let open Component.Signature in
995 List.map
996 (function
997 | RModule (id, p) -> RModule (id, module_path s p)
998 | RType (id, exp, eqn) ->
999 RType (id, type_expr s exp, type_decl_equation s eqn)
1000 | RModuleType (id, mty) -> RModuleType (id, module_type_expr s mty))
1001 items
1002
1003and signature s sg =
1004 let s, items = rename_bound_idents s [] sg.items in
1005 let items, removed, dont_recompile = apply_sig_map s items sg.removed in
1006 { sg with items; removed; compiled = sg.compiled && dont_recompile }
1007
1008and apply_sig_map_sg s (sg : Component.Signature.t) =
1009 let items, removed, dont_recompile = apply_sig_map s sg.items sg.removed in
1010 { sg with items; removed; compiled = sg.compiled && dont_recompile }
1011
1012and apply_sig_map_item s item =
1013 let open Component.Signature in
1014 match item with
1015 | Module (id, r, m) ->
1016 Module
1017 ( id,
1018 r,
1019 Component.Delayed.put (fun () -> module_ s (Component.Delayed.get m))
1020 )
1021 | ModuleSubstitution (id, m) ->
1022 ModuleSubstitution (id, module_substitution s m)
1023 | ModuleType (id, mt) ->
1024 ModuleType
1025 ( id,
1026 Component.Delayed.put (fun () ->
1027 module_type s (Component.Delayed.get mt)) )
1028 | ModuleTypeSubstitution (id, mt) ->
1029 ModuleTypeSubstitution (id, module_type_substitution s mt)
1030 | Type (id, r, t) ->
1031 Type
1032 ( id,
1033 r,
1034 Component.Delayed.put (fun () -> type_ s (Component.Delayed.get t)) )
1035 | TypeSubstitution (id, t) -> TypeSubstitution (id, type_ s t)
1036 | Exception (id, e) -> Exception (id, exception_ s e)
1037 | TypExt e -> TypExt (extension s e)
1038 | Value (id, v) ->
1039 Value
1040 (id, Component.Delayed.put (fun () -> value s (Component.Delayed.get v)))
1041 | Class (id, r, c) -> Class (id, r, class_ s c)
1042 | ClassType (id, r, c) -> ClassType (id, r, class_type s c)
1043 | Include i -> Include (include_ s i)
1044 | Open o -> Open (open_ s o)
1045 | Comment c -> Comment c
1046
1047and apply_sig_map_items s items =
1048 List.rev_map (apply_sig_map_item s) items |> List.rev
1049
1050and apply_sig_map s items removed =
1051 let dont_recompile = List.length s.path_invalidating_modules = 0 in
1052 (apply_sig_map_items s items, removed_items s removed, dont_recompile)