From 7d4d62e60439a8734564fde268db7b484a3c3b02 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 23 Feb 2021 18:55:48 +0100 Subject: [PATCH] Add the 'linked' flag to compilation units To ensures that linking is not done twice. This can happen when inadvertently using the `html` command instead of `html-generate`. Some elements can't be linked twice and will cause an exception. For example when linking `{!modules:...}`. --- src/loader/odoc_loader.ml | 8 ++++---- src/model/lang.ml | 2 ++ src/odoc/compile.ml | 5 ++++- src/odoc/html_fragment.ml | 3 ++- src/xref2/link.ml | 11 ++++++++--- test/xref2/lib/common.cppo.ml | 1 + 6 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index 67ace6dfdc..45b075c333 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -80,7 +80,7 @@ let read_cmti ~make_root ~parent ~filename () = in let content = Odoc_model.Lang.Compilation_unit.Module items in {Odoc_model.Lang.Compilation_unit.id; root; doc; digest; imports; source; - interface; hidden; content; expansion = None} + interface; hidden; content; expansion = None; linked = false} end | _ -> not_an_interface filename @@ -138,7 +138,7 @@ let read_cmt ~make_root ~parent ~filename () = let source = None in let content = Odoc_model.Lang.Compilation_unit.Pack items in {Odoc_model.Lang.Compilation_unit.id; root; doc; digest; imports; - source; interface; hidden; content; expansion = None} + source; interface; hidden; content; expansion = None; linked = false} | Implementation impl -> let name = cmt_info.cmt_modname in @@ -173,7 +173,7 @@ let read_cmt ~make_root ~parent ~filename () = in let content = Odoc_model.Lang.Compilation_unit.Module items in {Odoc_model.Lang.Compilation_unit.id; root; doc; digest; imports; - source; interface; hidden; content; expansion = None} + source; interface; hidden; content; expansion = None; linked = false} | _ -> not_an_implementation filename @@ -203,7 +203,7 @@ let read_cmi ~make_root ~parent ~filename () = let source = None in let content = Odoc_model.Lang.Compilation_unit.Module items in {Odoc_model.Lang.Compilation_unit.id; root; doc; digest; imports; - source; interface; hidden; content; expansion = None} + source; interface; hidden; content; expansion = None; linked = false} | _ -> corrupted filename diff --git a/src/model/lang.ml b/src/model/lang.ml index 18d84ef408..5a8360e60d 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -441,6 +441,7 @@ module rec Compilation_unit : sig hidden : bool; content : content; expansion : Signature.t option; + linked : bool; (** Whether this unit has been linked. *) } end = Compilation_unit @@ -452,6 +453,7 @@ module rec Page : sig content : Comment.docs; children : Reference.t list; digest : Digest.t; + linked : bool; } end = Page diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 1cf8d0c5ea..c1522693e3 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -164,7 +164,10 @@ let mld ~parent_spec ~output ~children ~warn_error input = } in let resolve content = - let page = Odoc_model.Lang.Page.{ name; root; children; content; digest } in + let page = + Odoc_model.Lang.Page. + { name; root; children; content; digest; linked = false } + in Page.save output page; Ok () in diff --git a/src/odoc/html_fragment.ml b/src/odoc/html_fragment.ml index 69e6ac0407..df7ebadabd 100644 --- a/src/odoc/html_fragment.ml +++ b/src/odoc/html_fragment.ml @@ -13,7 +13,8 @@ let from_mld ~xref_base_uri ~env ~output ~warn_error input = let to_html content = (* This is a mess. *) let page = - Odoc_model.Lang.Page.{ name = id; root; content; children = []; digest } + Odoc_model.Lang.Page. + { name = id; root; content; children = []; digest; linked = false } in let resolve_env = Env.build env (`Page page) in Odoc_xref2.Link.resolve_page resolve_env page diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 5637595775..e7c4e61f32 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -118,7 +118,7 @@ let rec unit (resolver : Env.resolver) t = | Pack _ as p -> (p, env) in let doc = comment_docs env t.doc in - { t with content; doc; imports } + { t with content; doc; imports; linked = true } and value_ env parent t = let open Value in @@ -844,7 +844,9 @@ let build_resolver : fun ?equal:_ ?hash:_ lookup_unit resolve_unit lookup_page resolve_page -> { Env.lookup_unit; resolve_unit; lookup_page; resolve_page } *) -let link x y = Lookup_failures.catch_failures (fun () -> unit x y) +let link x y = + Lookup_failures.catch_failures (fun () -> + if y.Lang.Compilation_unit.linked then y else unit x y) let page env page = let env = Env.set_resolver Env.empty env in @@ -863,6 +865,9 @@ let page env page = Page.content = List.map (with_location comment_block_element env) page.Page.content; children; + linked = true; } -let resolve_page env p = Lookup_failures.catch_failures (fun () -> page env p) +let resolve_page env p = + Lookup_failures.catch_failures (fun () -> + if p.Lang.Page.linked then p else page env p) diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 3b7c40ac9c..0c6b217007 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -604,6 +604,7 @@ let my_compilation_unit id docs s = ; hidden = false ; content = Module s ; expansion = None + ; linked = false } let mkenv () =