jon.recoil.org
this repo has no description
1(* Phase 1 - compilation *)
2
3(* First round of resolving only attempts to resolve paths and fragments, and then only those
4 that don't contain forward paths *)
5
6open Odoc_model
7open Lang
8module Id = Paths.Identifier
9
10module Opt = struct
11 let map f = function Some x -> Some (f x) | None -> None
12end
13
14let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t =
15 fun env p ->
16 match p with
17 | `Resolved _ -> p
18 | _ -> (
19 let cp = Component.Of_Lang.(type_path (empty ()) p) in
20 match Tools.resolve_type_path env cp with
21 | Ok p' -> `Resolved Lang_of.(Path.resolved_type (empty ()) p')
22 | Error _ -> p)
23
24and value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t =
25 fun env p ->
26 match p with
27 | `Resolved _ -> p
28 | _ -> (
29 let cp = Component.Of_Lang.(value_path (empty ()) p) in
30 match Tools.resolve_value_path env cp with
31 | Ok p' -> `Resolved Lang_of.(Path.resolved_value (empty ()) p')
32 | Error _ -> p)
33
34and module_type_path :
35 Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t =
36 fun env p ->
37 match p with
38 | `Resolved _ -> p
39 | _ -> (
40 let cp = Component.Of_Lang.(module_type_path (empty ()) p) in
41 match Tools.resolve_module_type_path env cp with
42 | Ok p' -> `Resolved Lang_of.(Path.resolved_module_type (empty ()) p')
43 | Error _ -> p)
44
45and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t =
46 fun env p ->
47 match p with
48 | `Resolved _ -> p
49 | _ -> (
50 let cp = Component.Of_Lang.(module_path (empty ()) p) in
51 match Tools.resolve_module_path env cp with
52 | Ok p' -> `Resolved Lang_of.(Path.resolved_module (empty ()) p')
53 | Error _ -> p)
54
55and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t
56 =
57 fun env p ->
58 match p with
59 | `Resolved _ -> p
60 | _ -> (
61 let cp = Component.Of_Lang.(class_type_path (empty ()) p) in
62 match Tools.resolve_class_type_path env cp with
63 | Ok p' -> `Resolved Lang_of.(Path.resolved_class_type (empty ()) p')
64 | Error _ -> p)
65
66let rec unit env t =
67 let open Compilation_unit in
68 { t with content = content env t.id t.content }
69
70and implementation env sp =
71 let open Implementation in
72 { sp with source_info = source_info_infos env sp.source_info }
73
74and source_info_infos env infos =
75 let open Source_info in
76 let map_doc f v =
77 let documentation =
78 match v.documentation with Some p -> Some (f p) | None -> None
79 in
80 { v with documentation }
81 in
82 List.map
83 (function
84 | v, pos ->
85 let v =
86 match v with
87 | Value v -> Value (map_doc (value_path env) v)
88 | Module v -> Module (map_doc (module_path env) v)
89 | ModuleType v -> ModuleType (map_doc (module_type_path env) v)
90 | Type v -> Type (map_doc (type_path env) v)
91 | Definition _ as d -> d
92 in
93 (v, pos))
94 infos
95
96and content env id =
97 let open Compilation_unit in
98 function
99 | Module sg ->
100 let sg = signature env (id :> Id.Signature.t) sg in
101 Module sg
102 | Pack p -> Pack p
103
104and value_ env parent t =
105 let open Value in
106 let container = (parent :> Id.LabelParent.t) in
107 try { t with type_ = type_expression env container t.type_ }
108 with _ ->
109 Errors.report ~what:(`Value t.id) `Compile;
110 t
111
112and exception_ env parent e =
113 let open Exception in
114 let container = (parent :> Id.LabelParent.t) in
115 let res = Opt.map (type_expression env container) e.res in
116 let args = type_decl_constructor_argument env container e.args in
117 { e with res; args }
118
119and extension env parent t =
120 let open Extension in
121 let container = (parent :> Id.LabelParent.t) in
122 let constructor c =
123 let open Constructor in
124 {
125 c with
126 args = type_decl_constructor_argument env container c.args;
127 res = Opt.map (type_expression env container) c.res;
128 }
129 in
130 let type_path = type_path env t.type_path in
131 let constructors = List.rev_map constructor t.constructors |> List.rev in
132 { t with type_path; constructors }
133
134and class_type_expr env parent =
135 let open ClassType in
136 let container = (parent :> Id.LabelParent.t) in
137 function
138 | Constr (path, texps) ->
139 Constr
140 ( class_type_path env path,
141 List.rev_map (type_expression env container) texps |> List.rev )
142 | Signature s -> Signature (class_signature env parent s)
143
144and class_type env c =
145 let open ClassType in
146 let expansion =
147 match
148 let open Odoc_utils.OptionMonad in
149 Env.(lookup_by_id s_class_type) c.id env >>= fun (`ClassType (_, c')) ->
150 Tools.class_signature_of_class_type env c' >>= fun sg ->
151 let cs =
152 Lang_of.class_signature (Lang_of.empty ())
153 (c.id :> Paths.Identifier.Path.ClassType.t)
154 sg
155 in
156 let compiled = class_signature env (c.id :> Id.ClassSignature.t) cs in
157 Some compiled
158 with
159 | Some _ as exp -> exp
160 | None ->
161 Errors.report ~what:(`Class_type c.id) `Expand;
162 c.expansion
163 in
164 {
165 c with
166 expr = class_type_expr env (c.id :> Id.ClassSignature.t) c.expr;
167 expansion;
168 }
169
170and class_signature env parent c =
171 let open ClassSignature in
172 let container = (parent : Id.ClassSignature.t :> Id.LabelParent.t) in
173 let env = Env.open_class_signature c env in
174 let map_item = function
175 | Method m -> Method (method_ env parent m)
176 | InstanceVariable i -> InstanceVariable (instance_variable env parent i)
177 | Constraint cst -> Constraint (class_constraint env container cst)
178 | Inherit ih -> Inherit (inherit_ env parent ih)
179 | Comment c -> Comment c
180 in
181 {
182 c with
183 self = Opt.map (type_expression env container) c.self;
184 items = List.rev_map map_item c.items |> List.rev;
185 }
186
187and method_ env parent m =
188 let open Method in
189 let container = (parent :> Id.LabelParent.t) in
190 { m with type_ = type_expression env container m.type_ }
191
192and instance_variable env parent i =
193 let open InstanceVariable in
194 let container = (parent :> Id.LabelParent.t) in
195 { i with type_ = type_expression env container i.type_ }
196
197and class_constraint env parent cst =
198 let open ClassSignature.Constraint in
199 {
200 cst with
201 left = type_expression env parent cst.left;
202 right = type_expression env parent cst.right;
203 }
204
205and inherit_ env parent ih =
206 let open ClassSignature.Inherit in
207 { ih with expr = class_type_expr env parent ih.expr }
208
209and class_ env parent c =
210 let open Class in
211 let container = (parent :> Id.LabelParent.t) in
212 let expansion =
213 match
214 let open Odoc_utils.OptionMonad in
215 Env.(lookup_by_id s_class) c.id env >>= fun (`Class (_, c')) ->
216 Tools.class_signature_of_class env c' >>= fun sg ->
217 let cs =
218 Lang_of.class_signature (Lang_of.empty ())
219 (c.id :> Paths.Identifier.Path.ClassType.t)
220 sg
221 in
222 Some (class_signature env (c.id :> Id.ClassSignature.t) cs)
223 with
224 | Some _ as exp -> exp
225 | None ->
226 Errors.report ~what:(`Class c.id) `Expand;
227 c.expansion
228 in
229 let rec map_decl = function
230 | ClassType expr ->
231 ClassType (class_type_expr env (c.id :> Id.ClassSignature.t) expr)
232 | Arrow (lbl, expr, decl) ->
233 Arrow (lbl, type_expression env container expr, map_decl decl)
234 in
235 { c with type_ = map_decl c.type_; expansion }
236
237and module_substitution env m =
238 let open ModuleSubstitution in
239 { m with manifest = module_path env m.manifest }
240
241and signature_items : Env.t -> Id.Signature.t -> Signature.item list -> _ =
242 fun initial_env id s ->
243 let open Signature in
244 let rec loop items env xs =
245 match xs with
246 | [] -> (List.rev items, env)
247 | item :: rest -> (
248 match item with
249 | Module (Nonrec, _) -> assert false
250 | Module (r, m) ->
251 let add_to_env env m =
252 let ty =
253 Component.Delayed.(
254 put (fun () -> Component.Of_Lang.(module_ (empty ()) m)))
255 in
256 Env.add_module
257 (m.id :> Paths.Identifier.Path.Module.t)
258 ty
259 { elements = []; warnings_tag = None }
260 env
261 in
262 let env =
263 match r with
264 | Nonrec -> assert false
265 | And | Ordinary -> env
266 | Rec ->
267 let rec find modules rest =
268 match rest with
269 | Module (And, m') :: sgs -> find (m' :: modules) sgs
270 | Module (_, _) :: _ -> modules
271 | Comment _ :: sgs -> find modules sgs
272 | _ -> modules
273 in
274 let modules = find [ m ] rest in
275 List.fold_left add_to_env env modules
276 in
277 let m' = module_ env m in
278 let env'' =
279 match r with
280 | Nonrec -> assert false
281 | And | Rec -> env
282 | Ordinary -> add_to_env env m'
283 in
284 loop (Module (r, m') :: items) env'' rest
285 | ModuleSubstitution m ->
286 let env' = Env.open_module_substitution m env in
287 loop
288 (ModuleSubstitution (module_substitution env m) :: items)
289 env' rest
290 | Type (r, t) ->
291 let add_to_env env t =
292 let ty = Component.Of_Lang.(type_decl (empty ()) t) in
293 Env.add_type t.id ty env
294 in
295 let env' =
296 match r with
297 | Rec -> assert false
298 | Ordinary ->
299 let rec find types rest =
300 match rest with
301 | Type (And, t) :: sgs -> find (t :: types) sgs
302 | Type (_, _) :: _ -> types
303 | Comment _ :: sgs -> find types sgs
304 | _ -> types
305 in
306 let types = find [ t ] rest in
307 List.fold_left add_to_env env types
308 | And | Nonrec -> env
309 in
310 let t' = type_decl env' t in
311 let env'' =
312 match r with
313 | Rec -> assert false
314 | Ordinary | And -> env'
315 | Nonrec -> add_to_env env' t'
316 in
317 loop (Type (r, t') :: items) env'' rest
318 | TypeSubstitution t ->
319 let env' = Env.open_type_substitution t env in
320 loop (TypeSubstitution (type_decl env t) :: items) env' rest
321 | ModuleType mt ->
322 let m' = module_type env mt in
323 let ty = Component.Of_Lang.(module_type (empty ()) m') in
324 let env' = Env.add_module_type mt.id ty env in
325 let items' = ModuleType m' :: items in
326 loop items' env' rest
327 | ModuleTypeSubstitution mt ->
328 let env' = Env.open_module_type_substitution mt env in
329 loop
330 (ModuleTypeSubstitution (module_type_substitution env mt) :: items)
331 env' rest
332 | Value v -> loop (Value (value_ env id v) :: items) env rest
333 | Comment c -> loop (Comment c :: items) env rest
334 | TypExt t -> loop (TypExt (extension env id t) :: items) env rest
335 | Exception e ->
336 loop (Exception (exception_ env id e) :: items) env rest
337 | Class (r, c) ->
338 let ty = Component.Of_Lang.(class_ (empty ()) c) in
339 let env' = Env.add_class c.id ty env in
340 let c' = class_ env' id c in
341 loop (Class (r, c') :: items) env' rest
342 | ClassType (r, c) ->
343 let ty = Component.Of_Lang.(class_type (empty ()) c) in
344 let env' = Env.add_class_type c.id ty env in
345 let c' = class_type env' c in
346 loop (ClassType (r, c') :: items) env' rest
347 | Include i ->
348 let i', env' = include_ env i in
349 loop (Include i' :: items) env' rest
350 | Open o -> loop (Open o :: items) env rest)
351 in
352 loop [] initial_env s
353
354and module_type_substitution env mt =
355 let open ModuleTypeSubstitution in
356 {
357 mt with
358 manifest = module_type_expr env (mt.id :> Id.Signature.t) mt.manifest;
359 }
360
361and signature : Env.t -> Id.Signature.t -> Signature.t -> _ =
362 fun env id s ->
363 if s.compiled then s
364 else
365 let items, _ = signature_items env id s.items in
366 {
367 Signature.items;
368 compiled = true;
369 removed = s.removed;
370 doc = s.doc (* comments are ignored while compiling *);
371 }
372
373and module_ : Env.t -> Module.t -> Module.t =
374 fun env m ->
375 let open Module in
376 { m with type_ = module_decl env (m.id :> Id.Signature.t) m.type_ }
377
378and module_decl : Env.t -> Id.Signature.t -> Module.decl -> Module.decl =
379 fun env id decl ->
380 let open Module in
381 match decl with
382 | ModuleType expr -> ModuleType (module_type_expr env id expr)
383 | Alias (p, expn) -> Alias (module_path env p, expn)
384
385and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
386 fun env id decl ->
387 let open Include in
388 match decl with
389 | ModuleType expr ->
390 let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
391 function
392 | Path _ -> false
393 | Signature _ -> true
394 | With (_, expr) -> is_elidable_with_u expr
395 | TypeOf _ -> false
396 | Strengthen (expr, _, _) -> is_elidable_with_u expr
397 in
398 if is_elidable_with_u expr then ModuleType expr
399 else ModuleType (u_module_type_expr env id expr)
400 | Alias p -> Alias (module_path env p)
401
402and module_type : Env.t -> ModuleType.t -> ModuleType.t =
403 fun env m ->
404 let open ModuleType in
405 let sg_id = (m.id :> Id.Signature.t) in
406 let expr =
407 match m.expr with
408 | None -> None
409 | Some e -> Some (module_type_expr env sg_id ~expand_paths:false e)
410 in
411 { m with expr }
412
413and include_ : Env.t -> Include.t -> Include.t * Env.t =
414 fun env i ->
415 let open Include in
416 let decl = Component.Of_Lang.(include_decl (empty ()) i.decl) in
417 let get_expansion () =
418 match
419 let open Odoc_utils.ResultMonad in
420 match decl with
421 | Alias p ->
422 Tools.expansion_of_module_path env ~strengthen:true p >>= fun exp ->
423 Tools.assert_not_functor exp
424 | ModuleType mty -> Tools.signature_of_u_module_type_expr env mty
425 with
426 | Error e ->
427 Errors.report ~what:(`Include decl) ~tools_error:e `Expand;
428 i.expansion
429 | Ok sg ->
430 let map = Lang_of.with_shadowed i.expansion.shadowed in
431 let sg' =
432 match i.strengthened with
433 | Some p ->
434 let cp = Component.Of_Lang.(module_path (empty ()) p) in
435 Strengthen.signature cp sg
436 | None -> sg
437 in
438 let sg'' = Tools.apply_inner_substs env sg' in
439 let e = Lang_of.(simple_expansion map i.parent (Signature sg'')) in
440 let expansion_sg =
441 match e with
442 | ModuleType.Signature sg -> sg
443 | _ ->
444 failwith "Expansion shouldn't be anything other than a signature"
445 in
446 { i.expansion with content = expansion_sg }
447 in
448 let expansion =
449 if i.expanded then i.expansion
450 else get_expansion ()
451 in
452 let items, env' = signature_items env i.parent expansion.content.items in
453 let expansion =
454 {
455 expansion with
456 content = { expansion.content with items; compiled = true };
457 }
458 in
459 let decl = include_decl env i.parent i.decl in
460 (* After compilation, expanded=true marks includes as "already
461 derived by odoc" — the expansion is authoritative without
462 re-derivation from the decl. Inline Signature decls are stripped
463 as a size optimization since the expansion is shown inline. *)
464 let stripped, decl =
465 match decl with
466 | Include.ModuleType (Signature _) ->
467 true,
468 Include.ModuleType (Signature
469 { items = []; compiled = true; removed = []; doc = i.doc })
470 | _ -> false, decl
471 in
472 ({ i with decl; expansion; expanded = true }, env')
473
474and simple_expansion :
475 Env.t ->
476 Id.Signature.t ->
477 ModuleType.simple_expansion ->
478 ModuleType.simple_expansion =
479 fun env id e ->
480 match e with
481 | Signature sg -> Signature (signature env id sg)
482 | Functor (param, sg) ->
483 let env' = Env.add_functor_parameter param env in
484 Functor
485 ( functor_parameter env param,
486 simple_expansion env' (Paths.Identifier.Mk.result id) sg )
487
488and functor_parameter : Env.t -> FunctorParameter.t -> FunctorParameter.t =
489 fun env param ->
490 match param with
491 | Unit -> Unit
492 | Named arg -> Named (functor_parameter_parameter env arg)
493
494and functor_parameter_parameter :
495 Env.t -> FunctorParameter.parameter -> FunctorParameter.parameter =
496 fun env a ->
497 { a with expr = module_type_expr env (a.id :> Id.Signature.t) a.expr }
498
499and module_type_expr_sub id ~fragment_root (sg_res, env, subs) lsub =
500 let open Odoc_utils.ResultMonad in
501 match sg_res with
502 | Error _ -> (sg_res, env, lsub :: subs)
503 | Ok sg -> (
504 let lang_of_map = Lang_of.with_fragment_root fragment_root in
505 let env = Env.add_fragment_root sg env in
506 let sg_and_sub =
507 match lsub with
508 | Odoc_model.Lang.ModuleType.ModuleEq (frag, decl) ->
509 let cfrag = Component.Of_Lang.(module_fragment (empty ()) frag) in
510 let cfrag', frag' =
511 match
512 Tools.resolve_module_fragment env (fragment_root, sg) cfrag
513 with
514 | Some cfrag' ->
515 ( `Resolved cfrag',
516 `Resolved
517 (Lang_of.Path.resolved_module_fragment lang_of_map cfrag')
518 )
519 | None ->
520 Errors.report ~what:(`With_module cfrag) `Resolve;
521 (cfrag, frag)
522 in
523 let decl' = module_decl env id decl in
524 let cdecl' = Component.Of_Lang.(module_decl (empty ()) decl') in
525 let resolved_csub =
526 Component.ModuleType.ModuleEq (cfrag', cdecl')
527 in
528 Tools.fragmap env resolved_csub sg >>= fun sg' ->
529 Ok (sg', Odoc_model.Lang.ModuleType.ModuleEq (frag', decl'))
530 | TypeEq (frag, eqn) ->
531 let cfrag = Component.Of_Lang.(type_fragment (empty ()) frag) in
532 let cfrag', frag' =
533 match
534 Tools.resolve_type_fragment env (fragment_root, sg) cfrag
535 with
536 | Some cfrag' ->
537 ( `Resolved cfrag',
538 `Resolved
539 (Lang_of.Path.resolved_type_fragment lang_of_map cfrag')
540 )
541 | None ->
542 Errors.report ~what:(`With_type cfrag) `Compile;
543 (cfrag, frag)
544 in
545 let eqn' = type_decl_equation env (id :> Id.LabelParent.t) eqn in
546 let ceqn' = Component.Of_Lang.(type_equation (empty ()) eqn') in
547 Tools.fragmap env (Component.ModuleType.TypeEq (cfrag', ceqn')) sg
548 >>= fun sg' ->
549 Ok (sg', Odoc_model.Lang.ModuleType.TypeEq (frag', eqn'))
550 | ModuleSubst (frag, mpath) ->
551 let cfrag = Component.Of_Lang.(module_fragment (empty ()) frag) in
552 let cfrag', frag' =
553 match
554 Tools.resolve_module_fragment env (fragment_root, sg) cfrag
555 with
556 | Some cfrag ->
557 ( `Resolved cfrag,
558 `Resolved
559 (Lang_of.Path.resolved_module_fragment lang_of_map cfrag)
560 )
561 | None ->
562 Errors.report ~what:(`With_module cfrag) `Resolve;
563 (cfrag, frag)
564 in
565 let mpath' = module_path env mpath in
566 let cmpath' = Component.Of_Lang.(module_path (empty ()) mpath') in
567 Tools.fragmap env
568 (Component.ModuleType.ModuleSubst (cfrag', cmpath'))
569 sg
570 >>= fun sg' ->
571 Ok (sg', Odoc_model.Lang.ModuleType.ModuleSubst (frag', mpath'))
572 | TypeSubst (frag, eqn) ->
573 let cfrag = Component.Of_Lang.(type_fragment (empty ()) frag) in
574 let cfrag', frag' =
575 match
576 Tools.resolve_type_fragment env (fragment_root, sg) cfrag
577 with
578 | Some cfrag ->
579 ( `Resolved cfrag,
580 `Resolved
581 (Lang_of.Path.resolved_type_fragment lang_of_map cfrag) )
582 | None ->
583 Errors.report ~what:(`With_type cfrag) `Compile;
584 (cfrag, frag)
585 in
586 let eqn' = type_decl_equation env (id :> Id.LabelParent.t) eqn in
587 let ceqn' = Component.Of_Lang.(type_equation (empty ()) eqn') in
588 Tools.fragmap env
589 (Component.ModuleType.TypeSubst (cfrag', ceqn'))
590 sg
591 >>= fun sg' ->
592 Ok (sg', Odoc_model.Lang.ModuleType.TypeSubst (frag', eqn'))
593 | ModuleTypeEq (frag, mty) ->
594 let cfrag =
595 Component.Of_Lang.(module_type_fragment (empty ()) frag)
596 in
597 let cfrag', frag' =
598 match
599 Tools.resolve_module_type_fragment env (fragment_root, sg) cfrag
600 with
601 | Some cfrag' ->
602 ( `Resolved cfrag',
603 `Resolved
604 (Lang_of.Path.resolved_module_type_fragment lang_of_map
605 cfrag') )
606 | None ->
607 Errors.report ~what:(`With_module_type cfrag) `Resolve;
608 (cfrag, frag)
609 in
610 let mty = module_type_expr env id mty in
611 let mty' = Component.Of_Lang.(module_type_expr (empty ()) mty) in
612 let resolved_csub =
613 Component.ModuleType.ModuleTypeEq (cfrag', mty')
614 in
615 Tools.fragmap env resolved_csub sg >>= fun sg' ->
616 Ok (sg', Odoc_model.Lang.ModuleType.ModuleTypeEq (frag', mty))
617 | Odoc_model.Lang.ModuleType.ModuleTypeSubst (frag, mty) ->
618 let cfrag =
619 Component.Of_Lang.(module_type_fragment (empty ()) frag)
620 in
621 let cfrag', frag' =
622 match
623 Tools.resolve_module_type_fragment env (fragment_root, sg) cfrag
624 with
625 | Some cfrag' ->
626 ( `Resolved cfrag',
627 `Resolved
628 (Lang_of.Path.resolved_module_type_fragment lang_of_map
629 cfrag') )
630 | None ->
631 Errors.report ~what:(`With_module_type cfrag) `Resolve;
632 (cfrag, frag)
633 in
634 let mty = module_type_expr env id mty in
635 let mty' = Component.Of_Lang.(module_type_expr (empty ()) mty) in
636 let resolved_csub =
637 Component.ModuleType.ModuleTypeSubst (cfrag', mty')
638 in
639 Tools.fragmap env resolved_csub sg >>= fun sg' ->
640 Ok (sg', Odoc_model.Lang.ModuleType.ModuleTypeSubst (frag', mty))
641 in
642
643 match sg_and_sub with
644 | Ok (sg', sub') -> (Ok sg', env, sub' :: subs)
645 | Error _ -> (sg_res, env, lsub :: subs))
646
647and module_type_map_subs env id cexpr subs =
648 let rec find_parent : Component.ModuleType.U.expr -> Cfrag.root option =
649 fun expr ->
650 match expr with
651 | Component.ModuleType.U.Signature _ -> None
652 | Path (`Resolved p) -> Some (`ModuleType p)
653 | Path _ -> None
654 | With (_, e) -> find_parent e
655 | TypeOf (ModPath (`Resolved p), _) | TypeOf (StructInclude (`Resolved p), _)
656 ->
657 Some (`Module p)
658 | TypeOf _ -> None
659 | Strengthen (e, _, _) -> find_parent e
660 in
661 match find_parent cexpr with
662 | None -> None
663 | Some parent -> (
664 match Tools.signature_of_u_module_type_expr env cexpr with
665 | Error e ->
666 Errors.report ~what:(`Module_type id) ~tools_error:e `Lookup;
667 None
668 | Ok sg ->
669 let fragment_root =
670 match parent with (`ModuleType _ | `Module _) as x -> x
671 in
672 let _, _, subs =
673 List.fold_left
674 (module_type_expr_sub (id :> Id.Signature.t) ~fragment_root)
675 (Ok sg, env, []) subs
676 in
677 let subs = List.rev subs in
678 Some subs)
679
680and u_module_type_expr :
681 Env.t -> Id.Signature.t -> ModuleType.U.expr -> ModuleType.U.expr =
682 fun env id expr ->
683 let open ModuleType in
684 let rec inner : U.expr -> U.expr = function
685 | Signature s -> Signature s
686 | Path p -> Path (module_type_path env p)
687 | With (subs, expr) ->
688 let expr' = inner expr in
689 let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) expr') in
690 let subs' =
691 match module_type_map_subs env id cexpr subs with
692 | Some s -> s
693 | None -> subs
694 in
695 let result : ModuleType.U.expr = With (subs', expr') in
696 result
697 | TypeOf (t_desc, t_original_path) ->
698 let t_desc =
699 match t_desc with
700 | ModPath p -> ModPath (module_path env p)
701 | StructInclude p -> StructInclude (module_path env p)
702 in
703 TypeOf (t_desc, t_original_path)
704 | Strengthen (expr, path, aliasable) ->
705 Strengthen (inner expr, module_path env path, aliasable)
706 in
707 inner expr
708
709and module_type_expr :
710 Env.t ->
711 Id.Signature.t ->
712 ?expand_paths:bool ->
713 ModuleType.expr ->
714 ModuleType.expr =
715 fun env id ?(expand_paths = true) expr ->
716 let open Odoc_utils.ResultMonad in
717 let get_expansion cur e =
718 match cur with
719 | Some e -> Some (simple_expansion env id e)
720 | None -> (
721 let ce = Component.Of_Lang.(module_type_expr (empty ()) e) in
722 match
723 Tools.expansion_of_module_type_expr env ce
724 >>= Expand_tools.handle_expansion env id
725 with
726 | Ok (_, ce) ->
727 let e = Lang_of.simple_expansion (Lang_of.empty ()) id ce in
728 Some (simple_expansion env id e)
729 | Error `OpaqueModule -> None
730 | Error e ->
731 Errors.report ~what:(`Module_type_expr ce) ~tools_error:e `Expand;
732 None)
733 in
734 match expr with
735 | Signature s -> Signature (signature env id s)
736 | Path { p_path; p_expansion } as e ->
737 let p_expansion =
738 if expand_paths then get_expansion p_expansion e else p_expansion
739 in
740 Path { p_path = module_type_path env p_path; p_expansion }
741 | With { w_substitutions; w_expansion; w_expr } as e -> (
742 let w_expansion = get_expansion w_expansion e in
743 let rec all_withs = function
744 | ModuleType.U.With (_, e) -> all_withs e
745 | Signature _ -> true
746 | _ -> false
747 in
748 match (all_withs w_expr, w_expansion) with
749 | true, Some (Signature e) -> Signature e
750 | _ -> (
751 let w_expr = u_module_type_expr env id w_expr in
752 let cexpr =
753 Component.Of_Lang.(u_module_type_expr (empty ()) w_expr)
754 in
755 let subs' = module_type_map_subs env id cexpr w_substitutions in
756 match subs' with
757 | None -> With { w_substitutions; w_expansion; w_expr }
758 | Some s -> With { w_substitutions = s; w_expansion; w_expr }))
759 | Functor (param, res) ->
760 let param' = functor_parameter env param in
761 let env' = Env.add_functor_parameter param env in
762 let res' = module_type_expr env' (Paths.Identifier.Mk.result id) res in
763 Functor (param', res')
764 | TypeOf { t_desc; t_original_path; t_expansion } as e ->
765 let t_expansion = get_expansion t_expansion e in
766 let t_desc =
767 match t_desc with
768 | ModPath p -> ModuleType.ModPath (module_path env p)
769 | StructInclude p -> StructInclude (module_path env p)
770 in
771 TypeOf { t_desc; t_original_path; t_expansion }
772 | Strengthen { s_expr; s_path; s_aliasable; s_expansion } as e ->
773 let s_expansion = get_expansion s_expansion e in
774 let s_expr = u_module_type_expr env id s_expr in
775 let s_path = module_path env s_path in
776 Strengthen { s_expr; s_path; s_aliasable; s_expansion }
777
778and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t =
779 fun env t ->
780 let open TypeDecl in
781 let container =
782 match t.id.iv with `Type (parent, _) -> (parent :> Id.LabelParent.t)
783 in
784 let equation = type_decl_equation env container t.equation in
785 let representation =
786 Opt.map (type_decl_representation env container) t.representation
787 in
788 { t with equation; representation }
789
790and type_decl_equation :
791 Env.t -> Id.LabelParent.t -> TypeDecl.Equation.t -> TypeDecl.Equation.t =
792 fun env parent t ->
793 let open TypeDecl.Equation in
794 let manifest = Opt.map (type_expression env parent) t.manifest in
795 let constraints =
796 List.map
797 (fun (tex1, tex2) ->
798 (type_expression env parent tex1, type_expression env parent tex2))
799 t.constraints
800 in
801 { t with manifest; constraints }
802
803and type_decl_representation :
804 Env.t ->
805 Id.LabelParent.t ->
806 TypeDecl.Representation.t ->
807 TypeDecl.Representation.t =
808 fun env parent r ->
809 let open TypeDecl.Representation in
810 match r with
811 | Variant cs -> Variant (List.map (type_decl_constructor env parent) cs)
812 | Record fs -> Record (List.map (type_decl_field env parent) fs)
813 | Record_unboxed_product fs ->
814 Record_unboxed_product (List.map (type_decl_unboxed_field env parent) fs)
815 | Extensible -> Extensible
816
817and type_decl_field env parent f =
818 let open TypeDecl.Field in
819 { f with type_ = type_expression env parent f.type_ }
820
821and type_decl_unboxed_field env parent f =
822 let open TypeDecl.UnboxedField in
823 { f with type_ = type_expression env parent f.type_ }
824
825and type_decl_constructor_argument env parent c =
826 let open TypeDecl.Constructor in
827 match c with
828 | Tuple ts -> Tuple (List.map (type_expression env parent) ts)
829 | Record fs -> Record (List.map (type_decl_field env parent) fs)
830
831and type_decl_constructor :
832 Env.t ->
833 Id.LabelParent.t ->
834 TypeDecl.Constructor.t ->
835 TypeDecl.Constructor.t =
836 fun env parent c ->
837 let open TypeDecl.Constructor in
838 let args = type_decl_constructor_argument env parent c.args in
839 let res = Opt.map (type_expression env parent) c.res in
840 { c with args; res }
841
842and type_expression_polyvar env parent v =
843 let open TypeExpr.Polymorphic_variant in
844 let constructor c =
845 let open Constructor in
846 { c with arguments = List.map (type_expression env parent) c.arguments }
847 in
848 let element = function
849 | Type t -> Type (type_expression env parent t)
850 | Constructor c -> Constructor (constructor c)
851 in
852 { v with elements = List.map element v.elements }
853
854and type_expression_object env parent o =
855 let open TypeExpr.Object in
856 let method_ m = { m with type_ = type_expression env parent m.type_ } in
857 let field = function
858 | Method m -> Method (method_ m)
859 | Inherit t -> Inherit (type_expression env parent t)
860 in
861 { o with fields = List.map field o.fields }
862
863and type_expression_package env parent p =
864 let open TypeExpr.Package in
865 let cp = Component.Of_Lang.(module_type_path (empty ()) p.path) in
866 match Tools.resolve_module_type env cp with
867 | Ok (path, mt) -> (
868 match p.substitutions with
869 | [] ->
870 (* No substitutions, don't need to try to resolve them *)
871 { path = module_type_path env p.path; substitutions = [] }
872 | _ -> (
873 match Tools.expansion_of_module_type env mt with
874 | Error e ->
875 Errors.report ~what:(`Package cp) ~tools_error:e `Lookup;
876 p
877 | Ok (Functor _) ->
878 failwith "Type expression package of functor with substitutions!"
879 | Ok (Signature sg) ->
880 let substitution (frag, t) =
881 let cfrag = Component.Of_Lang.(type_fragment (empty ()) frag) in
882 let frag' =
883 match
884 Tools.resolve_type_fragment env (`ModuleType path, sg) cfrag
885 with
886 | Some cfrag' ->
887 `Resolved
888 (Lang_of.(Path.resolved_type_fragment (empty ()))
889 cfrag')
890 | None ->
891 Errors.report ~what:(`Type cfrag) `Compile;
892 frag
893 in
894 (frag', type_expression env parent t)
895 in
896 {
897 path = module_type_path env p.path;
898 substitutions = List.map substitution p.substitutions;
899 }))
900 | Error _ -> { p with path = Lang_of.(Path.module_type (empty ()) cp) }
901
902and handle_arrow :
903 Env.t ->
904 Id.Id.label_parent ->
905 TypeExpr.label option ->
906 TypeExpr.t ->
907 TypeExpr.t ->
908 string list ->
909 string list ->
910 TypeExpr.t =
911 fun env parent lbl t1 t2 modes ret_modes ->
912 let t2' = type_expression env parent t2 in
913 match lbl with
914 | Some (Optional _ | Label _) | None ->
915 Arrow (lbl, type_expression env parent t1, t2', modes, ret_modes)
916 | Some (RawOptional s) -> (
917 (* s is definitely an option type, but not _obviously_ so. *)
918 match Component.Of_Lang.(type_expression (empty ()) t1) with
919 | Constr (p, _ts) -> (
920 (* This handles only the simplest case *)
921 let find_option t =
922 match Tools.resolve_type env t with
923 | Ok (_, `FType (_n, decl)) -> (
924 match decl.equation.manifest with
925 | Some (Constr (`Resolved (`CoreType n), [ t ]))
926 when Names.TypeName.to_string n = "option" ->
927 let t = Lang_of.(type_expr (empty ()) parent t) in
928 Some t
929 | Some _ -> None
930 | None -> None)
931 | Ok (_, `CoreType _) -> None
932 | Ok (_, (`FClass _ | `FClassType _ | `FType_removed _)) -> None
933 | Error _ -> None
934 in
935 match find_option p with
936 | Some t1 ->
937 Arrow (Some (Optional s), type_expression env parent t1, t2', modes, ret_modes)
938 | None ->
939 Arrow (Some (RawOptional s), type_expression env parent t1, t2', modes, ret_modes))
940 | _ -> Arrow (Some (RawOptional s), type_expression env parent t1, t2', modes, ret_modes))
941
942and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
943 fun env parent texpr ->
944 let open TypeExpr in
945 match texpr with
946 | Var _ | Any -> texpr
947 | Alias (t, str) -> Alias (type_expression env parent t, str)
948 | Arrow (lbl, t1, t2, modes, ret_modes) -> handle_arrow env parent lbl t1 t2 modes ret_modes
949 | Tuple ts ->
950 Tuple
951 (List.map (fun (lbl, ty) -> (lbl, type_expression env parent ty)) ts)
952 | Unboxed_tuple ts ->
953 Unboxed_tuple (List.map (fun (l, t) -> l, type_expression env parent t) ts)
954 | Constr (path, ts') -> (
955 let cp = Component.Of_Lang.(type_path (empty ()) path) in
956 let ts = List.map (type_expression env parent) ts' in
957 match Tools.resolve_type env cp with
958 | Ok (cp, (`FType _ | `FClass _ | `FClassType _ | `CoreType _)) ->
959 let p = Lang_of.(Path.resolved_type (empty ()) cp) in
960 Constr (`Resolved p, ts)
961 | Ok (_cp, `FType_removed (_, x, _eq)) ->
962 (* Substitute type variables ? *)
963 Lang_of.(type_expr (empty ()) parent x)
964 | Error _e ->
965 Constr ((Lang_of.(Path.type_ (empty ()) cp) :> Paths.Path.Type.t), ts)
966 )
967 | Polymorphic_variant v ->
968 Polymorphic_variant (type_expression_polyvar env parent v)
969 | Object o -> Object (type_expression_object env parent o)
970 | Class (path, ts) -> (
971 let ts' = List.map (type_expression env parent) ts in
972 let cp = Component.Of_Lang.(class_type_path (empty ()) path) in
973 match Tools.resolve_class_type env cp with
974 | Ok (cp, (`FClass _ | `FClassType _)) ->
975 let p = Lang_of.(Path.resolved_class_type (empty ()) cp) in
976 Class (`Resolved p, ts')
977 | _ -> Class (path, ts'))
978 | Poly (strs, t) -> Poly (strs, type_expression env parent t)
979 | Quote t -> Quote (type_expression env parent t)
980 | Splice t -> Splice (type_expression env parent t)
981 | Package p -> Package (type_expression_package env parent p)
982
983let compile ~filename env compilation_unit =
984 Lookup_failures.catch_failures ~filename (fun () -> unit env compilation_unit)
985
986let compile_impl ~filename env i =
987 Lookup_failures.catch_failures ~filename (fun () -> implementation env i)
988
989let resolve_page _resolver y = y