From 39007e7ca8a5be05b1fa491131b2219a66bb0db2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Sat, 24 Oct 2020 00:58:54 +0100 Subject: [PATCH 1/3] Fix a looping forever issue with 'module type of' When expanding `module type of` expressions we loop in case there's a nested instance of one. This adds some logic to avoid looping if there's no change in the signature, which can happen if the unexpanded module type of expression is in a different module. Signed-off-by: Jon Ludlam --- src/xref2/compile.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 63a0b93932..da590ca38a 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -67,8 +67,9 @@ and content env id = let sg' = Type_of.signature env sg in Tools.reset_caches (); if !Type_of.again - then loop sg' - else sg' in + then begin + if sg' = sg then sg else loop sg' + end else sg' in let sg = loop m in Module (signature env (id :> Id.Signature.t) sg) | Pack _ -> failwith "Unhandled content" From 74ab37102a55f7f628b6310db98446be469efda9 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Sat, 24 Oct 2020 11:34:31 +0100 Subject: [PATCH 2/3] Get rid of exceptions for use in Xref2.Type_of Use the usual error types instead. Fixes #500 Signed-off-by: Jon Ludlam --- src/xref2/compile.ml | 4 +++- src/xref2/component.ml | 8 ++++++-- src/xref2/component.mli | 2 ++ src/xref2/errors.ml | 8 +++++++- src/xref2/expand_tools.ml | 4 ++-- src/xref2/tools.ml | 13 ++++++++----- src/xref2/tools.mli | 2 -- src/xref2/type_of.ml | 4 ++-- 8 files changed, 30 insertions(+), 15 deletions(-) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index da590ca38a..868005c824 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -514,7 +514,9 @@ and module_type_expr : | Ok (_, _, ce) -> let e = Lang_of.simple_expansion Lang_of.empty id ce in Some (simple_expansion env id e) - | Error _ -> None + | Error e -> + Errors.report ~what:(`Module_type_expr ce) ~tools_error:e `Expand; + None in match expr with | Signature s -> Signature (signature env id s) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 794b913a98..9b8274bd0b 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -632,6 +632,11 @@ module Fmt = struct | Some x -> Format.fprintf ppf "= %a" module_type_expr x | None -> () + and module_type_type_of_desc ppf t = + match t with + | ModuleType.ModPath p -> Format.fprintf ppf "module type of %a" module_path p + | StructInclude p -> Format.fprintf ppf "module type of struct include %a end" module_path p + and u_module_type_expr ppf mt = let open ModuleType.U in match mt with @@ -640,8 +645,7 @@ module Fmt = struct | With (subs, e) -> Format.fprintf ppf "%a with [%a]" u_module_type_expr e substitution_list subs - | TypeOf { t_desc = ModPath p; _ }-> Format.fprintf ppf "module type of %a" module_path p - | TypeOf { t_desc = StructInclude p; _ } -> Format.fprintf ppf "module type of struct include %a end" module_path p + | TypeOf { t_desc; _ } -> module_type_type_of_desc ppf t_desc and module_type_expr ppf mt = let open ModuleType in diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 9c93c53945..2cf4ebda29 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -489,6 +489,8 @@ module Fmt : sig val simple_expansion : Format.formatter -> ModuleType.simple_expansion -> unit + val module_type_type_of_desc : Format.formatter -> ModuleType.type_of_desc -> unit + val u_module_type_expr : Format.formatter -> ModuleType.U.expr -> unit val module_type_expr : Format.formatter -> ModuleType.expr -> unit diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 33cd03845f..77db693b34 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -14,7 +14,9 @@ module Tools_error = struct (** The module signature depends upon a forward path *) | `UnresolvedPath of [ `Module of Cpath.module_ | `ModuleType of Cpath.module_type ] - (** The path to the module or module type could not be resolved *) ] + (** The path to the module or module type could not be resolved *) + | `UnexpandedTypeOf of Component.ModuleType.type_of_desc + (** The `module type of` expression could not be expanded *) ] type simple_module_lookup_error = [ `Local of Env.t * Ident.path_module @@ -110,6 +112,10 @@ module Tools_error = struct | `ApplyNotFunctor -> Format.fprintf fmt "Apply module is not a functor" | `Class_replaced -> Format.fprintf fmt "Class replaced" | `Parent p -> pp_parent fmt p + | `UnexpandedTypeOf t -> + Format.fprintf fmt "Unexpanded `module type of` expression: %a" + Component.Fmt.module_type_type_of_desc t + and pp_parent : Format.formatter -> parent_lookup_error -> unit = fun fmt err -> diff --git a/src/xref2/expand_tools.ml b/src/xref2/expand_tools.ml index 180d5a5120..dc7a668a45 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -124,7 +124,7 @@ and aux_expansion_of_u_module_type_expr env expr : let subs = unresolve_subs subs in Tools.handle_signature_with_subs ~mark_substituted:false env sg subs) | TypeOf { t_expansion = Some (Signature sg); _} -> Ok sg - | TypeOf _ -> raise Tools.UnexpandedTypeOf + | TypeOf { t_desc; _ } -> Error (`UnexpandedTypeOf t_desc) and aux_expansion_of_module_type_expr env expr : (expansion, signature_of_module_error) Result.result = @@ -142,7 +142,7 @@ and aux_expansion_of_module_type_expr env expr : >>= fun sg -> Ok (Signature sg) | Functor (arg, expr) -> Ok (Functor (arg, expr)) | TypeOf {t_expansion = Some (Signature sg); _} -> Ok (Signature sg) - | TypeOf _ -> raise Tools.UnexpandedTypeOf + | TypeOf {t_desc; _} -> Error (`UnexpandedTypeOf t_desc) and aux_expansion_of_module_type env mt = let open Component.ModuleType in diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index a6a5458900..860e98ffd8 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -4,7 +4,6 @@ open Odoc_model.Names open Utils open ResultMonad -exception UnexpandedTypeOf type ('a, 'b) either = Left of 'a | Right of 'b type module_modifiers = @@ -1014,7 +1013,7 @@ and signature_of_u_module_type_expr : signature_of_u_module_type_expr ~mark_substituted env s >>= fun sg -> handle_signature_with_subs ~mark_substituted env sg subs | TypeOf { t_expansion = Some (Signature sg); _ } -> Ok sg - | TypeOf _ -> raise UnexpandedTypeOf + | TypeOf { t_desc; _ } -> Error (`UnexpandedTypeOf t_desc ) and signature_of_simple_expansion : Component.ModuleType.simple_expansion -> Component.Signature.t = function @@ -1047,7 +1046,8 @@ and signature_of_module_type_expr : signature_of_module_type_expr ~mark_substituted env expr | Component.ModuleType.TypeOf { t_expansion = Some e; _ } -> Ok (signature_of_simple_expansion e) - | Component.ModuleType.TypeOf _ -> raise UnexpandedTypeOf + | Component.ModuleType.TypeOf { t_desc; _ } -> + Error (`UnexpandedTypeOf t_desc) and signature_of_module_type : Env.t -> @@ -1463,6 +1463,7 @@ and resolve_module_fragment : | Ok (_m : Component.Signature.t) -> f' | Error `OpaqueModule -> `OpaqueModule f' | Error (`UnresolvedForwardPath | `UnresolvedPath _) -> f' + | Error (`UnexpandedTypeOf _ ) -> f' in Some (fixup_module_cfrag f'') @@ -1548,14 +1549,16 @@ let resolve_module_path env p = match signature_of_module_cached env p m with | Ok _ -> Ok p | Error `OpaqueModule -> Ok (`OpaqueModule p) - | Error (`UnresolvedForwardPath | `UnresolvedPath _) -> Ok p ) + | Error (`UnresolvedForwardPath | `UnresolvedPath _) -> Ok p + | Error (`UnexpandedTypeOf _) -> Ok p) let resolve_module_type_path env p = resolve_module_type ~mark_substituted:true env p >>= fun (p, mt) -> match signature_of_module_type env mt with | Ok _ -> Ok p | Error `OpaqueModule -> Ok (`OpaqueModuleType p) - | Error (`UnresolvedForwardPath | `UnresolvedPath _) -> Ok p + | Error (`UnresolvedForwardPath | `UnresolvedPath _) + | Error (`UnexpandedTypeOf _) -> Ok p let resolve_type_path env p = resolve_type env p >>= fun (p, _) -> Ok p diff --git a/src/xref2/tools.mli b/src/xref2/tools.mli index dc844a7c8f..e28668e914 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -7,8 +7,6 @@ open Errors.Tools_error -exception UnexpandedTypeOf - (** {2 Lookup and resolve functions} *) (** The following lookup and resolve functions take {{!module:Cpath.Resolved}resolved paths} diff --git a/src/xref2/type_of.ml b/src/xref2/type_of.ml index a9f339014e..b8847958df 100644 --- a/src/xref2/type_of.ml +++ b/src/xref2/type_of.ml @@ -61,8 +61,8 @@ and module_type_expr env (id : Id.Signature.t) expr = | TypeOf t -> match module_type_expr_typeof env id t with | Ok e -> TypeOf {t with t_expansion = Some (Lang_of.(simple_expansion empty id e)) } + | Error (`UnexpandedTypeOf _) -> again := true; expr | Error _ -> expr - | exception _ -> again := true; expr and u_module_type_expr env id expr = match expr with @@ -72,8 +72,8 @@ and u_module_type_expr env id expr = | TypeOf t -> match module_type_expr_typeof env id t with | Ok e -> TypeOf {t with t_expansion = Some (Lang_of.(simple_expansion empty id e)) } + | Error (`UnexpandedTypeOf _) -> again := true; expr | Error _ -> expr - | exception _ -> again := true; expr and functor_parameter env p = { p with expr = module_type_expr env (p.id :> Id.Signature.t) p.expr} From 3192488c30c00fa6dc1df40c0f9399cccc6e99c7 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Sat, 24 Oct 2020 11:43:39 +0100 Subject: [PATCH 3/3] Add some more tests for `module type of` These tests target the issues fixed in the previous few commits. Signed-off-by: Jon Ludlam --- test/xref2/multi_file_module_type_of.t/run.t | 41 +++++++++++++++++++ .../multi_file_module_type_of.t/test0.mli | 1 + .../multi_file_module_type_of.t/test1.mli | 2 + .../multi_file_module_type_of.t/test2.mli | 2 + test/xref2/multi_module_type_of.t/run.t | 24 +++++++++++ test/xref2/multi_module_type_of.t/test.mli | 4 ++ test/xref2/unexpanded_module_type_of.t/run.t | 21 ++++++++++ .../unexpanded_module_type_of.t/test.mli | 2 + .../unexpanded_module_type_of.t/test0.mli | 1 + 9 files changed, 98 insertions(+) create mode 100644 test/xref2/multi_file_module_type_of.t/run.t create mode 100644 test/xref2/multi_file_module_type_of.t/test0.mli create mode 100644 test/xref2/multi_file_module_type_of.t/test1.mli create mode 100644 test/xref2/multi_file_module_type_of.t/test2.mli create mode 100644 test/xref2/multi_module_type_of.t/run.t create mode 100644 test/xref2/multi_module_type_of.t/test.mli create mode 100644 test/xref2/unexpanded_module_type_of.t/run.t create mode 100644 test/xref2/unexpanded_module_type_of.t/test.mli create mode 100644 test/xref2/unexpanded_module_type_of.t/test0.mli diff --git a/test/xref2/multi_file_module_type_of.t/run.t b/test/xref2/multi_file_module_type_of.t/run.t new file mode 100644 index 0000000000..9b8ab6be3f --- /dev/null +++ b/test/xref2/multi_file_module_type_of.t/run.t @@ -0,0 +1,41 @@ +Module type of across multiple modules +====================================== + +The logic to keep looping when we have nested `module type of` expressions needs +to know when to stop. If the unexpanded `module type of` expression is actually in +a separate module, no matter how many times we try it'll never work. Thus there is +some logic to check before it loops to see if the signature has changed at all. +If not, it doesn't loop. Without this logic, the following test would loop forever + +Here are the test files: + + $ cat test0.mli + type t + + $ cat test1.mli + module S : module type of Test0 + + $ cat test2.mli + module T : module type of Test1.S + + $ ocamlc -c -bin-annot test0.mli + $ ocamlc -c -bin-annot test1.mli + $ ocamlc -c -bin-annot test2.mli + +In this instance, module S will not be expanded because we are not providing an +odoc file for `Test0` - so there will be a warning when we run `odoc compile` +on test1.cmti: + + $ odoc compile --package foo test1.cmti + File "test1.cmti": + Failed to compile expansion for module type expression module type of unresolvedroot(Test0) Unexpanded `module type of` expression: module type of unresolvedroot(Test0) + +Similarly, module `T` also can not be expanded, therefore we expect +another warning when we run `odoc compile` on test2.cmti: + + $ odoc compile --package foo test2.cmti -I . + File "test2.cmti": + Failed to compile expansion for module type expression module type of unresolvedroot(Test1).S Unexpanded `module type of` expression: module type of unresolvedroot(Test1).S + +Crucially though, we do expect this command to have terminated! + diff --git a/test/xref2/multi_file_module_type_of.t/test0.mli b/test/xref2/multi_file_module_type_of.t/test0.mli new file mode 100644 index 0000000000..63c57c4e0c --- /dev/null +++ b/test/xref2/multi_file_module_type_of.t/test0.mli @@ -0,0 +1 @@ +type t diff --git a/test/xref2/multi_file_module_type_of.t/test1.mli b/test/xref2/multi_file_module_type_of.t/test1.mli new file mode 100644 index 0000000000..a95b93e043 --- /dev/null +++ b/test/xref2/multi_file_module_type_of.t/test1.mli @@ -0,0 +1,2 @@ +module S : module type of Test0 + diff --git a/test/xref2/multi_file_module_type_of.t/test2.mli b/test/xref2/multi_file_module_type_of.t/test2.mli new file mode 100644 index 0000000000..593f6b4c0b --- /dev/null +++ b/test/xref2/multi_file_module_type_of.t/test2.mli @@ -0,0 +1,2 @@ +module T : module type of Test1.S + diff --git a/test/xref2/multi_module_type_of.t/run.t b/test/xref2/multi_module_type_of.t/run.t new file mode 100644 index 0000000000..d0666297cd --- /dev/null +++ b/test/xref2/multi_module_type_of.t/run.t @@ -0,0 +1,24 @@ +Multiple `module type of` statements +==================================== + +The way the `module type of` logic works is that an initial pass is made over the +signature looking for `module type of` expressions and expanding them there and then. +If there are 'nested' `module type of` expressions, that is, we're trying to find +the type of a module that either is, or contains, a `module type of` expression +itself, then we loop. + +This is a test of this nested situation. Expanding module Z requires module Y +to have been expanded. + + $ cat test.mli + module X : sig type t end + module Y : module type of struct include X end + module Z : module type of Y + + +If we correctly expand all of the `module type of` expressions there should be no +warnings raised when we compile the module. + + $ ocamlc -c -bin-annot test.mli + $ odoc compile --package test test.cmti + diff --git a/test/xref2/multi_module_type_of.t/test.mli b/test/xref2/multi_module_type_of.t/test.mli new file mode 100644 index 0000000000..0440975598 --- /dev/null +++ b/test/xref2/multi_module_type_of.t/test.mli @@ -0,0 +1,4 @@ +module X : sig type t end +module Y : module type of struct include X end +module Z : module type of Y + diff --git a/test/xref2/unexpanded_module_type_of.t/run.t b/test/xref2/unexpanded_module_type_of.t/run.t new file mode 100644 index 0000000000..48ffb061fa --- /dev/null +++ b/test/xref2/unexpanded_module_type_of.t/run.t @@ -0,0 +1,21 @@ +Unexpanded `module type of` +=========================== + +This is a test for [this issue](https://github.com/ocaml/odoc/issues/500) + + $ cat test0.mli + type t + + $ cat test.mli + module M: sig include module type of Test0 end + + $ ocamlc -c -bin-annot test0.mli + $ ocamlc -c -bin-annot test.mli + +Compiling an odoc file for `test` without compiling one for `test0` +should _not_ result in an exception, merely a warning. + + $ odoc compile --package test test.cmti + File "test.cmti": + Failed to compile expansion for include : module type of unresolvedroot(Test0) Unexpanded `module type of` expression: module type of unresolvedroot(Test0) + diff --git a/test/xref2/unexpanded_module_type_of.t/test.mli b/test/xref2/unexpanded_module_type_of.t/test.mli new file mode 100644 index 0000000000..7cfc92d476 --- /dev/null +++ b/test/xref2/unexpanded_module_type_of.t/test.mli @@ -0,0 +1,2 @@ +module M: sig include module type of Test0 end + diff --git a/test/xref2/unexpanded_module_type_of.t/test0.mli b/test/xref2/unexpanded_module_type_of.t/test0.mli new file mode 100644 index 0000000000..63c57c4e0c --- /dev/null +++ b/test/xref2/unexpanded_module_type_of.t/test0.mli @@ -0,0 +1 @@ +type t