rpms/ocaml-odoc
3
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add 3 patches for OCaml 4.10 compatibility.

Browse Source
This commit is contained in:
Jerry James 2020-02-01 08:16:44 -07:00
parent 6c707705d3
commit 18240f7b30
4 changed files with 2096 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
0001-Emit-quote-before-identifier-in-alias-type-exprs.patch Normal file
View File

@ -0,0 +1,54 @@
From acf7732ec95332b4589eea397409d02cfb8867d3 Mon Sep 17 00:00:00 2001
From: Anton Bachin <antonbachin@yahoo.com>
Date: Wed, 6 Nov 2019 13:04:58 +0300
Subject: [PATCH] Emit quote before identifier in alias type exprs
Fixes #391.
---
src/html/generator.ml | 2 +-
test/html/expect/test_package+ml/Type/index.html | 2 +-
test/html/expect/test_package+re/Type/index.html | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/src/html/generator.ml b/src/html/generator.ml
index 8ff697a..fd96630 100644
--- a/src/html/generator.ml
+++ b/src/html/generator.ml
@@ -179,7 +179,7 @@ struct
| Any -> [type_var Syntax.Type.any]
| Alias (te, alias) ->
type_expr ~needs_parentheses:true te @
- Html.txt " " :: keyword "as" :: Html.txt " " :: [ Html.txt alias ]
+ Html.txt " " :: keyword "as" :: Html.txt " '" :: [ Html.txt alias ]
| Arrow (None, src, dst) ->
let res =
type_expr ~needs_parentheses:true src @
diff --git a/test/html/expect/test_package+ml/Type/index.html b/test/html/expect/test_package+ml/Type/index.html
index 048b04d..882898e 100644
--- a/test/html/expect/test_package+ml/Type/index.html
+++ b/test/html/expect/test_package+ml/Type/index.html
@@ -367,7 +367,7 @@
<a href="#type-double_constrained" class="anchor"></a><code><span class="keyword">type</span> <span>('a, 'b) double_constrained</span></code><code> = <span class="type-var">'a</span> * <span class="type-var">'b</span></code><code> <span class="keyword">constraint</span> <span class="type-var">'a</span> = int <span class="keyword">constraint</span> <span class="type-var">'b</span> = unit</code>
</dt>
<dt class="spec type" id="type-as_">
- <a href="#type-as_" class="anchor"></a><code><span class="keyword">type</span> as_</code><code> = int <span class="keyword">as</span> a * <span class="type-var">'a</span></code>
+ <a href="#type-as_" class="anchor"></a><code><span class="keyword">type</span> as_</code><code> = int <span class="keyword">as</span> 'a * <span class="type-var">'a</span></code>
</dt>
<dt class="spec type" id="type-extensible">
<a href="#type-extensible" class="anchor"></a><code><span class="keyword">type</span> extensible</code><code> = </code><code>..</code>
diff --git a/test/html/expect/test_package+re/Type/index.html b/test/html/expect/test_package+re/Type/index.html
index 783db65..ee630e3 100644
--- a/test/html/expect/test_package+re/Type/index.html
+++ b/test/html/expect/test_package+re/Type/index.html
@@ -371,7 +371,7 @@
<a href="#type-double_constrained" class="anchor"></a><code><span class="keyword">type</span> double_constrained('a, 'b)</code><code> = <span>(<span class="type-var">'a</span>, <span class="type-var">'b</span>)</span></code><code> <span class="keyword">constraint</span> <span class="type-var">'a</span> = int <span class="keyword">constraint</span> <span class="type-var">'b</span> = unit</code>;
</dt>
<dt class="spec type" id="type-as_">
- <a href="#type-as_" class="anchor"></a><code><span class="keyword">type</span> as_</code><code> = <span>(int <span class="keyword">as</span> a, <span class="type-var">'a</span>)</span></code>;
+ <a href="#type-as_" class="anchor"></a><code><span class="keyword">type</span> as_</code><code> = <span>(int <span class="keyword">as</span> 'a, <span class="type-var">'a</span>)</span></code>;
</dt>
<dt class="spec type" id="type-extensible">
<a href="#type-extensible" class="anchor"></a><code><span class="keyword">type</span> extensible</code><code> = </code><code>..</code>;
--
2.24.1

914
0002-Handle-generalized-open-statements-393.patch Normal file
View File

@ -0,0 +1,914 @@
From 152481881b26873d6890519a8e8c15b35f6819bf Mon Sep 17 00:00:00 2001
From: Jon Ludlam <jon@recoil.org>
Date: Mon, 11 Nov 2019 15:01:06 +0000
Subject: [PATCH] Handle generalized open statements (#393)
We do this by introducing an artificial module at the point the `open`
occurs. For example:
```ocaml
open (Foo : module type of Foo with module A := Foo.A)
```
becomes effectively:
```ocaml
(**/**)
module Open__<line>_<col> : module type of Foo with module A := Foo.A
(**/**)
```
and we 'open' this by putting all of the identifiers into the environment.
All of these `Ident.t` values are associated with 'Internal' names that
are always hidden, and hence the resolution step ends up resolving them to
the non-hidden identifiers.
Signed-off-by: Jon Ludlam <jon@recoil.org>
---
src/loader/cmi.ml | 3 +-
src/loader/cmt.ml | 28 +++-
src/loader/cmti.ml | 23 +++-
src/model/dune | 5 +
src/model/ident_env.cppo.ml | 129 +++++++++++++-----
.../{ident_env.mli => ident_env.cppo.mli} | 18 ++-
src/model/names.ml | 81 +++++++++--
src/model/names.mli | 68 +++++++--
src/xref/expand.ml | 4 +-
test/html/cases/functor2.mli | 15 ++
test/html/cases/recent_impl.ml | 29 ++++
.../test_package+ml/Recent_impl/index.html | 44 ++++++
.../test_package+re/Recent_impl/index.html | 44 ++++++
test/html/test.ml | 4 +-
14 files changed, 425 insertions(+), 70 deletions(-)
rename src/model/{ident_env.mli => ident_env.cppo.mli} (80%)
create mode 100644 test/html/cases/functor2.mli
create mode 100644 test/html/cases/recent_impl.ml
create mode 100644 test/html/expect/test_package+ml/Recent_impl/index.html
create mode 100644 test/html/expect/test_package+re/Recent_impl/index.html
diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml
index f70714a..05f24eb 100644
--- a/src/loader/cmi.ml
+++ b/src/loader/cmi.ml
@@ -21,6 +21,7 @@ module OCamlPath = Path
open Odoc_model.Paths
open Odoc_model.Lang
+open Odoc_model.Names
module Env = Odoc_model.Ident_env
module Paths = Odoc_model.Paths
@@ -851,7 +852,7 @@ let rec read_module_type env parent pos (mty : Odoc_model.Compat.module_type) =
in
Some { FunctorArgument. id; expr = arg; expansion }
in
- let env = Env.add_argument parent pos id env in
+ let env = Env.add_argument parent pos id (ArgumentName.of_ident id) env in
let res = read_module_type env parent (pos + 1) res in
Functor(arg, res)
| Mty_alias _ -> assert false
diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml
index 57b74c5..892959a 100644
--- a/src/loader/cmt.ml
+++ b/src/loader/cmt.ml
@@ -372,7 +372,7 @@ let rec read_module_expr env parent label_parent pos mexpr =
in
Some { FunctorArgument. id; expr = arg; expansion }
in
- let env = Env.add_argument parent pos id env in
+ let env = Env.add_argument parent pos id (ArgumentName.of_ident id) env in
let res = read_module_expr env parent label_parent (pos + 1) res in
Functor(arg, res)
| Tmod_apply _ ->
@@ -434,6 +434,25 @@ and read_module_bindings env parent mbs =
|> fst
|> List.rev
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+and module_of_extended_open env parent o =
+ let open Module in
+ let id = `Module (parent, Odoc_model.Names.ModuleName.internal_of_string (Env.module_name_of_open o)) in
+ let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
+ let type_ =
+ match unwrap_module_expr_desc o.open_expr.mod_desc with
+ | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p)
+ | _ -> ModuleType (read_module_expr env id container 1 o.open_expr)
+ in
+ { id
+ ; doc = []
+ ; type_
+ ; canonical = None
+ ; hidden = true
+ ; display_type = None
+ ; expansion = None }
+#endif
+
and read_structure_item env parent item =
let open Signature in
match item.str_desc with
@@ -471,7 +490,12 @@ and read_structure_item env parent item =
read_module_bindings env parent mbs
| Tstr_modtype mtd ->
[ModuleType (Cmti.read_module_type_declaration env parent mtd)]
- | Tstr_open _ -> []
+ | Tstr_open o ->
+#if OCAML_MAJOR = 4 && OCAML_MINOR < 08
+ ignore(o); []
+#else
+ [Comment `Stop; Module (Ordinary, module_of_extended_open env parent o); Comment `Stop]
+#endif
| Tstr_include incl ->
[Include (read_include env parent incl)]
| Tstr_class cls ->
diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml
index 8156e8e..13afb84 100644
--- a/src/loader/cmti.ml
+++ b/src/loader/cmti.ml
@@ -21,6 +21,7 @@ module OCamlPath = Path
open Odoc_model.Paths
open Odoc_model.Lang
+open Odoc_model.Names
module Env = Odoc_model.Ident_env
module Paths = Odoc_model.Paths
@@ -491,7 +492,7 @@ and read_module_type env parent label_parent pos mty =
in
Some { FunctorArgument. id; expr = arg; expansion }
in
- let env = Env.add_argument parent pos id env in
+ let env = Env.add_argument parent pos id (ArgumentName.of_ident id) env in
let res = read_module_type env parent label_parent (pos + 1) res in
Functor(arg, res)
| Tmty_with(body, subs) ->
@@ -573,6 +574,21 @@ and read_module_equation env p =
let open Module in
Alias (Env.Path.read_module env p)
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+and module_of_extended_open env parent o =
+ let open Module in
+ let id = `Module (parent, Odoc_model.Names.ModuleName.internal_of_string (Env.module_name_of_open o)) in
+ let (p,_) = o.Typedtree.open_expr in
+ let type_ = Alias (Env.Path.read_module env p) in
+ { id
+ ; doc = []
+ ; type_
+ ; canonical = None
+ ; hidden = true
+ ; display_type = None
+ ; expansion = None }
+#endif
+
and read_signature_item env parent item =
let open Signature in
match item.sig_desc with
@@ -604,7 +620,12 @@ and read_signature_item env parent item =
read_module_declarations env parent mds
| Tsig_modtype mtd ->
[ModuleType (read_module_type_declaration env parent mtd)]
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+ | Tsig_open o ->
+ [Comment `Stop; Module (Ordinary, module_of_extended_open env parent o); Comment `Stop]
+#else
| Tsig_open _ -> []
+#endif
| Tsig_include incl ->
[Include (read_include env parent incl)]
| Tsig_class cls ->
diff --git a/src/model/dune b/src/model/dune
index 3ae7f24..092efdd 100644
--- a/src/model/dune
+++ b/src/model/dune
@@ -14,6 +14,11 @@ let () =
(deps (:x ident_env.cppo.ml))
(action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets}))))
+(rule
+ (targets ident_env.mli)
+ (deps (:x ident_env.cppo.mli))
+ (action (chdir %{workspace_root} (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets}))))
+
(rule
(targets compat.ml)
(deps (:x compat.cppo.ml))
diff --git a/src/model/ident_env.cppo.ml b/src/model/ident_env.cppo.ml
index d6101c9..1534ecf 100644
--- a/src/model/ident_env.cppo.ml
+++ b/src/model/ident_env.cppo.ml
@@ -38,37 +38,36 @@ let empty =
let builtin_idents = List.map snd Predef.builtin_idents
-let should_be_hidden = Root.contains_double_underscore
+#if OCAML_MAJOR=4 && OCAML_MINOR >= 08
+let module_name_of_open o =
+ let loc_start = o.Typedtree.open_loc.Location.loc_start in
+ Printf.sprintf "Open__%d_%d" loc_start.Lexing.pos_lnum loc_start.pos_cnum
+#endif
-let add_module parent id env =
- let name = Ident.name id in
- let ident = `Identifier (`Module(parent, ModuleName.of_string name)) in
- let module_ = if should_be_hidden name then `Hidden ident else ident in
+let add_module parent id name env =
+ let ident = `Identifier (`Module(parent, name)) in
+ let module_ = if ModuleName.is_hidden name then `Hidden ident else ident in
let modules = Ident.add id module_ env.modules in
{ env with modules }
-let add_argument parent arg id env =
- let name = Ident.name id in
- let ident = `Identifier (`Argument(parent, arg, ArgumentName.of_string name)) in
- let module_ = if should_be_hidden name then `Hidden ident else ident in
+let add_argument parent arg id name env =
+ let ident = `Identifier (`Argument(parent, arg, name)) in
+ let module_ = if ArgumentName.is_hidden name then `Hidden ident else ident in
let modules = Ident.add id module_ env.modules in
{ env with modules }
-let add_module_type parent id env =
- let name = Ident.name id in
- let identifier = `ModuleType(parent, ModuleTypeName.of_string name) in
+let add_module_type parent id name env =
+ let identifier = `ModuleType(parent, name) in
let module_types = Ident.add id identifier env.module_types in
{ env with module_types }
-let add_type parent id env =
- let name = Ident.name id in
- let identifier = `Type(parent, TypeName.of_string name) in
+let add_type parent id name env =
+ let identifier = `Type(parent, name) in
let types = Ident.add id identifier env.types in
{ env with types }
-let add_class parent id ty_id obj_id cl_id env =
- let name = Ident.name id in
- let identifier = `Class(parent, ClassName.of_string name) in
+let add_class parent id ty_id obj_id cl_id name env =
+ let identifier = `Class(parent, name) in
let add_idents tbl =
Ident.add id identifier
(Ident.add ty_id identifier
@@ -79,9 +78,8 @@ let add_class parent id ty_id obj_id cl_id env =
let class_types = add_idents env.class_types in
{ env with types; class_types }
-let add_class_type parent id obj_id cl_id env =
- let name = Ident.name id in
- let identifier = `ClassType(parent, ClassTypeName.of_string name) in
+let add_class_type parent id obj_id cl_id name env =
+ let identifier = `ClassType(parent, name) in
let add_idents tbl =
Ident.add id identifier
(Ident.add obj_id identifier
@@ -91,27 +89,28 @@ let add_class_type parent id obj_id cl_id env =
let class_types = add_idents env.class_types in
{ env with types; class_types }
+
let rec add_signature_type_items parent items env =
let open Compat in
match items with
| Sig_type(id, _, _, Exported) :: rest ->
let env = add_signature_type_items parent rest env in
if Btype.is_row_name (Ident.name id) then env
- else add_type parent id env
+ else add_type parent id (TypeName.of_ident id) env
| Sig_module(id, _, _, _, Exported) :: rest ->
let env = add_signature_type_items parent rest env in
- add_module parent id env
+ add_module parent id (ModuleName.of_ident id) env
| Sig_modtype(id, _, Exported) :: rest ->
let env = add_signature_type_items parent rest env in
- add_module_type parent id env
+ add_module_type parent id (ModuleTypeName.of_ident id) env
| Sig_class(id, _, _, Exported) :: Sig_class_type(ty_id, _, _, _)
:: Sig_type(obj_id, _, _, _) :: Sig_type(cl_id, _, _, _) :: rest ->
let env = add_signature_type_items parent rest env in
- add_class parent id ty_id obj_id cl_id env
+ add_class parent id ty_id obj_id cl_id (ClassName.of_ident id) env
| Sig_class_type(id, _, _, Exported) :: Sig_type(obj_id, _, _, _)
:: Sig_type(cl_id, _, _, _) :: rest ->
let env = add_signature_type_items parent rest env in
- add_class_type parent id obj_id cl_id env
+ add_class_type parent id obj_id cl_id (ClassTypeName.of_ident id) env
| (Sig_value _ | Sig_typext _) :: rest ->
add_signature_type_items parent rest env
@@ -129,6 +128,52 @@ let rec add_signature_type_items parent items env =
| [] -> env
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+
+let rec unwrap_module_expr_desc = function
+ | Typedtree.Tmod_constraint(mexpr, _, Tmodtype_implicit, _) ->
+ unwrap_module_expr_desc mexpr.mod_desc
+ | desc -> desc
+
+let rec add_extended_open_items parent items env =
+ let open Types in
+ match items with
+ | Sig_type(id, _, _, _) :: rest ->
+ let env = add_extended_open_items parent rest env in
+ if Btype.is_row_name (Ident.name id) then env
+ else add_type parent id (TypeName.internal_of_ident id) env
+ | Sig_module(id, _, _, _, _) :: rest ->
+ let env = add_extended_open_items parent rest env in
+ add_module parent id (ModuleName.internal_of_ident id) env
+ | Sig_modtype(id, _, _) :: rest ->
+ let env = add_extended_open_items parent rest env in
+ add_module_type parent id (ModuleTypeName.internal_of_ident id) env
+ | Sig_class(id, _, _, _) :: Sig_class_type(ty_id, _, _, _)
+ :: Sig_type(obj_id, _, _, _) :: Sig_type(cl_id, _, _, _) :: rest ->
+ let env = add_extended_open_items parent rest env in
+ add_class parent id ty_id obj_id cl_id (ClassName.internal_of_ident id) env
+ | Sig_class_type(id, _, _, _) :: Sig_type(obj_id, _, _, _)
+ :: Sig_type(cl_id, _, _, _) :: rest ->
+ let env = add_extended_open_items parent rest env in
+ add_class_type parent id obj_id cl_id (ClassTypeName.internal_of_ident id) env
+ | (Sig_value _ | Sig_typext _) :: rest ->
+ add_extended_open_items parent rest env
+
+ | Sig_class _ :: _
+ | Sig_class_type _ :: _ -> assert false
+
+ | [] -> env
+
+let add_extended_open parent o env =
+ let open Typedtree in
+ match unwrap_module_expr_desc o.open_expr.mod_desc with
+ | Tmod_ident(_, _) -> env
+ | _ ->
+ let parent = `Module (parent, ModuleName.internal_of_string (module_name_of_open o)) in
+ add_extended_open_items parent o.open_bound_items env
+#endif
+
+
let add_signature_tree_item parent item env =
let open Typedtree in
match item.sig_desc with
@@ -138,16 +183,16 @@ let add_signature_tree_item parent item env =
| Tsig_type (_rec_flag, decls) -> (* TODO: handle rec_flag *)
#endif
List.fold_right
- (fun decl env -> add_type parent decl.typ_id env)
+ (fun decl env -> add_type parent decl.typ_id (TypeName.of_ident decl.typ_id) env)
decls env
| Tsig_module md ->
- add_module parent md.md_id env
+ add_module parent md.md_id (ModuleName.of_ident md.md_id) env
| Tsig_recmodule mds ->
List.fold_right
- (fun md env -> add_module parent md.md_id env)
+ (fun md env -> add_module parent md.md_id (ModuleName.of_ident md.md_id) env)
mds env
| Tsig_modtype mtd ->
- add_module_type parent mtd.mtd_id env
+ add_module_type parent mtd.mtd_id (ModuleTypeName.of_ident mtd.mtd_id) env
| Tsig_include incl ->
add_signature_type_items parent (Compat.signature incl.incl_type) env
| Tsig_class cls ->
@@ -160,6 +205,7 @@ let add_signature_tree_item parent item env =
#else
cld.ci_id_typehash
#endif
+ (ClassName.of_ident cld.ci_id_class)
env)
cls env
| Tsig_class_type cltyps ->
@@ -172,14 +218,15 @@ let add_signature_tree_item parent item env =
#else
clty.ci_id_typehash
#endif
+ (ClassTypeName.of_ident clty.ci_id_class_type)
env)
cltyps env
#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
| Tsig_modsubst ms ->
- add_module parent ms.ms_id env
+ add_module parent ms.ms_id (ModuleName.of_ident ms.ms_id) env
| Tsig_typesubst ts ->
List.fold_right
- (fun decl env -> add_type parent decl.typ_id env)
+ (fun decl env -> add_type parent decl.typ_id (TypeName.of_ident decl.typ_id) env)
ts env
#endif
| Tsig_value _ | Tsig_typext _
@@ -201,15 +248,15 @@ let add_structure_tree_item parent item env =
| Tstr_type (_rec_flag, decls) -> (* TODO: handle rec_flag *)
#endif
List.fold_right
- (fun decl env -> add_type parent decl.typ_id env)
+ (fun decl env -> add_type parent decl.typ_id (TypeName.of_ident decl.typ_id) env)
decls env
- | Tstr_module mb -> add_module parent mb.mb_id env
+ | Tstr_module mb -> add_module parent mb.mb_id (ModuleName.of_ident mb.mb_id) env
| Tstr_recmodule mbs ->
List.fold_right
- (fun mb env -> add_module parent mb.mb_id env)
+ (fun mb env -> add_module parent mb.mb_id (ModuleName.of_ident mb.mb_id) env)
mbs env
| Tstr_modtype mtd ->
- add_module_type parent mtd.mtd_id env
+ add_module_type parent mtd.mtd_id (ModuleTypeName.of_ident mtd.mtd_id) env
| Tstr_include incl ->
add_signature_type_items parent (Compat.signature incl.incl_type) env
| Tstr_class cls ->
@@ -226,6 +273,7 @@ let add_structure_tree_item parent item env =
#else
cld.ci_id_typehash
#endif
+ (ClassName.of_ident cld.ci_id_class)
env)
cls env
| Tstr_class_type cltyps ->
@@ -238,11 +286,18 @@ let add_structure_tree_item parent item env =
#else
clty.ci_id_typehash
#endif
+ (ClassTypeName.of_ident clty.ci_id_class_type)
env)
cltyps env
+#if OCAML_MAJOR = 4 && OCAML_MINOR < 08
+ | Tstr_open _ -> env
+#else
+ | Tstr_open o ->
+ add_extended_open parent o env
+#endif
| Tstr_eval _ | Tstr_value _
| Tstr_primitive _ | Tstr_typext _
- | Tstr_exception _ | Tstr_open _
+ | Tstr_exception _
| Tstr_attribute _ -> env
let add_structure_tree_items parent str env =
diff --git a/src/model/ident_env.mli b/src/model/ident_env.cppo.mli
similarity index 80%
rename from src/model/ident_env.mli
rename to src/model/ident_env.cppo.mli
index c41c29f..0fe0e93 100644
--- a/src/model/ident_env.mli
+++ b/src/model/ident_env.cppo.mli
@@ -14,21 +14,27 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
+open Names
+
type t
val empty : t
-val add_module : Paths.Identifier.Signature.t -> Ident.t -> t -> t
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+val module_name_of_open : 'a Typedtree.open_infos -> string
+#endif
+
+val add_module : Paths.Identifier.Signature.t -> Ident.t -> ModuleName.t -> t -> t
-val add_argument : Paths.Identifier.Signature.t -> int -> Ident.t -> t -> t
+val add_argument : Paths.Identifier.Signature.t -> int -> Ident.t -> ArgumentName.t -> t -> t
-val add_module_type : Paths.Identifier.Signature.t -> Ident.t -> t -> t
+val add_module_type : Paths.Identifier.Signature.t -> Ident.t -> ModuleTypeName.t -> t -> t
-val add_type : Paths.Identifier.Signature.t -> Ident.t -> t -> t
+val add_type : Paths.Identifier.Signature.t -> Ident.t -> TypeName.t -> t -> t
-val add_class : Paths.Identifier.Signature.t -> Ident.t -> Ident.t -> Ident.t -> Ident.t -> t -> t
+val add_class : Paths.Identifier.Signature.t -> Ident.t -> Ident.t -> Ident.t -> Ident.t -> ClassName.t -> t -> t
-val add_class_type : Paths.Identifier.Signature.t -> Ident.t -> Ident.t -> Ident.t -> t -> t
+val add_class_type : Paths.Identifier.Signature.t -> Ident.t -> Ident.t -> Ident.t -> ClassTypeName.t -> t -> t
val add_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t
diff --git a/src/model/names.ml b/src/model/names.ml
index cad32c4..550bb80 100644
--- a/src/model/names.ml
+++ b/src/model/names.ml
@@ -4,10 +4,18 @@ module type Name = sig
val to_string : t -> string
+ val to_string_unsafe : t -> string
+
val of_string : string -> t
val of_ident : Ident.t -> t
+ val internal_of_string : string -> t
+
+ val internal_of_ident : Ident.t -> t
+
+ val is_internal : t -> bool
+
val equal : t -> t -> bool
val is_hidden : t -> bool
@@ -16,6 +24,59 @@ end
module Name : Name = struct
+ type t =
+ | Internal of string
+ | Std of string
+
+ let to_string = function
+ | Std s -> s
+ | Internal s -> Printf.sprintf "$%s" s
+
+ let to_string_unsafe = function
+ | Std s -> s
+ | Internal s -> s
+
+ let of_string s = Std s
+
+ let of_ident id = of_string (Ident.name id)
+
+ let internal_of_string id = Internal id
+
+ let internal_of_ident id = internal_of_string (Ident.name id)
+
+ let is_internal = function | Std _ -> false | Internal _ -> true
+
+ let equal (x : t) (y : t) = x = y
+
+ let is_hidden = function
+ | Std s ->
+ let len = String.length s in
+ let rec aux i =
+ if i > len - 2 then false else
+ if s.[i] = '_' && s.[i + 1] = '_' then true
+ else aux (i + 1)
+ in aux 0
+ | Internal _ -> true
+end
+
+module type SimpleName = sig
+
+ type t
+
+ val to_string : t -> string
+
+ val of_string : string -> t
+
+ val of_ident : Ident.t -> t
+
+ val equal : t -> t -> bool
+
+ val is_hidden : t -> bool
+
+end
+
+module SimpleName : SimpleName = struct
+
type t = string
let to_string s = s
@@ -43,28 +104,28 @@ module ModuleTypeName = Name
module TypeName = Name
-module ConstructorName = Name
+module ConstructorName = SimpleName
-module FieldName = Name
+module FieldName = SimpleName
-module ExtensionName = Name
+module ExtensionName = SimpleName
-module ExceptionName = Name
+module ExceptionName = SimpleName
-module ValueName = Name
+module ValueName = SimpleName
module ClassName = Name
module ClassTypeName = Name
-module MethodName = Name
+module MethodName = SimpleName
-module InstanceVariableName = Name
+module InstanceVariableName = SimpleName
-module UnitName = Name
+module UnitName = SimpleName
-module LabelName = Name
+module LabelName = SimpleName
-module PageName = Name
+module PageName = SimpleName
diff --git a/src/model/names.mli b/src/model/names.mli
index 01999a1..d1f3ebc 100644
--- a/src/model/names.mli
+++ b/src/model/names.mli
@@ -1,18 +1,66 @@
+(** Typed names for paths, identifiers, references and fragments.
+
+ This module contains a module per type of named object in our internal
+ representation of the langage, each containing an opaque type [t].
+ This allows us to ensure that, for example, we never mistake a module
+ name for a module type name.
+*)
+
+(** Name is the signature for names that could possibly be internal. Internal
+ names occur when we generate items that don't have a path that will be
+ exposed in the generated HTML, for example, when we are doing generalised
+ opens. The compiler makes sure these new types are removed from the
+ signature, so they should never be externally visible, and an attempt to
+ turn an internal name into a string will result in an exception being thrown.
+
+ Note that it is tricky currently to remove references to internal names,
+ and hence the 'safe' [to_string] will not currently raise an exception. When
+ the model is updated to handle this the exception will be reinstated. *)
module type Name = sig
type t
val to_string : t -> string
+ (** [to_string_unsafe] will allow even internal names to be turned into
+ strings. Use with caution. *)
+ val to_string_unsafe : t -> string
+
val of_string : string -> t
val of_ident : Ident.t -> t
+ val internal_of_string : string -> t
+
+ val internal_of_ident : Ident.t -> t
+
+ val is_internal : t -> bool
+
val equal : t -> t -> bool
+ (** Hidden names are those that contain a double underscore, e.g.
+ [Hidden__module] *)
val is_hidden : t -> bool
end
+(** Some named objects can't have internal names, so they have this simpler
+ module. *)
+module type SimpleName = sig
+
+ type t
+
+ val to_string : t -> string
+
+ val of_string : string -> t
+
+ val of_ident : Ident.t -> t
+
+ val equal : t -> t -> bool
+
+ val is_hidden : t -> bool
+
+end
+
module ModuleName : Name
module ArgumentName : Name
@@ -21,26 +69,26 @@ module ModuleTypeName : Name
module TypeName : Name
-module ConstructorName : Name
+module ConstructorName : SimpleName
-module FieldName : Name
+module FieldName : SimpleName
-module ExtensionName : Name
+module ExtensionName : SimpleName
-module ExceptionName : Name
+module ExceptionName : SimpleName
-module ValueName : Name
+module ValueName : SimpleName
module ClassName : Name
module ClassTypeName : Name
-module MethodName : Name
+module MethodName : SimpleName
-module InstanceVariableName : Name
+module InstanceVariableName : SimpleName
-module UnitName : Name
+module UnitName : SimpleName
-module LabelName : Name
+module LabelName : SimpleName
-module PageName : Name
+module PageName : SimpleName
diff --git a/src/xref/expand.ml b/src/xref/expand.ml
index 836b9c0..db45fd1 100644
--- a/src/xref/expand.ml
+++ b/src/xref/expand.ml
@@ -458,7 +458,7 @@ let expand_signature_identifier' t root (id : Identifier.Signature.t) =
ex
| `Module(parent, name) ->
let ex = t.expand_signature_identifier ~root parent in
- let md = find_module t root (ModuleName.to_string name) ex in
+ let md = find_module t root (ModuleName.to_string_unsafe name) ex in
expand_module t root md
| `Argument(parent, pos, _name) ->
let ex = t.expand_signature_identifier ~root parent in
@@ -475,7 +475,7 @@ and expand_module_identifier' t root (id : Identifier.Module.t) =
| `Module(parent, name) ->
let open Module in
let ex = t.expand_signature_identifier ~root parent in
- let md = find_module t root (ModuleName.to_string name) ex in
+ let md = find_module t root (ModuleName.to_string_unsafe name) ex in
md.id, md.doc, md.canonical, expand_module t root md, []
| `Argument(parent, pos, _name) ->
let ex = t.expand_signature_identifier ~root parent in
diff --git a/test/html/cases/functor2.mli b/test/html/cases/functor2.mli
new file mode 100644
index 0000000..404e467
--- /dev/null
+++ b/test/html/cases/functor2.mli
@@ -0,0 +1,15 @@
+(* test *)
+
+module type S = sig type t end
+
+module X : functor (Y:S) -> functor (Z:S) -> sig
+ type y_t = Y.t
+ type z_t = Z.t
+ type x_t = y_t
+end
+
+module type XF = functor (Y:S) -> functor (Z:S) -> sig
+ type y_t = Y.t
+ type z_t = Z.t
+ type x_t = y_t
+end
diff --git a/test/html/cases/recent_impl.ml b/test/html/cases/recent_impl.ml
new file mode 100644
index 0000000..7aa10c9
--- /dev/null
+++ b/test/html/cases/recent_impl.ml
@@ -0,0 +1,29 @@
+module Foo = struct
+ module A = struct
+ type t = A
+ end
+ module B = struct
+ type t = B
+ end
+end
+
+open (Foo : module type of Foo with module A := Foo.A)
+
+module B = B
+
+open Set.Make(struct type t = Foo.A.t let compare = compare end)
+
+type u = t
+
+module type S = sig
+ module F: sig end -> sig type t end
+ module X: sig end
+ open F(X)
+ val f: t
+end
+
+open Foo
+
+(* Check that regular open still works as expected *)
+module B' = B
+
diff --git a/test/html/expect/test_package+ml/Recent_impl/index.html b/test/html/expect/test_package+ml/Recent_impl/index.html
new file mode 100644
index 0000000..9359a0a
--- /dev/null
+++ b/test/html/expect/test_package+ml/Recent_impl/index.html
@@ -0,0 +1,44 @@
+<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+ Recent_impl (test_package+ml.Recent_impl)
+ </title>
+ <link rel="stylesheet" href="../../odoc.css">
+ <meta charset="utf-8">
+ <meta name="generator" content="odoc %%VERSION%%">
+ <meta name="viewport" content="width=device-width,initial-scale=1.0">
+ <script src="../../highlight.pack.js"></script>
+ <script>
+ hljs.initHighlightingOnLoad();
+ </script>
+ </head>
+ <body>
+ <div class="content">
+ <header>
+ <nav>
+ <a href="../index.html">Up</a> – <a href="../index.html">test_package+ml</a> » Recent_impl
+ </nav>
+ <h1>
+ Module <code>Recent_impl</code>
+ </h1>
+ </header>
+ <div class="spec module" id="module-Foo">
+ <a href="#module-Foo" class="anchor"></a><code><span class="keyword">module</span> <a href="Foo/index.html">Foo</a> : <span class="keyword">sig</span> ... <span class="keyword">end</span></code>
+ </div>
+ <div class="spec module" id="module-B">
+ <a href="#module-B" class="anchor"></a><code><span class="keyword">module</span> B = <a href="$Open__10_123/index.html#module-$B">$B</a></code>
+ </div>
+ <dl>
+ <dt class="spec type" id="type-u">
+ <a href="#type-u" class="anchor"></a><code><span class="keyword">type</span> u</code><code> = <a href="$Open__14_193/index.html#type-$t">$t</a></code>
+ </dt>
+ </dl>
+ <div class="spec module-type" id="module-type-S">
+ <a href="#module-type-S" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S/index.html">S</a> = <span class="keyword">sig</span> ... <span class="keyword">end</span></code>
+ </div>
+ <div class="spec module" id="module-B'">
+ <a href="#module-B'" class="anchor"></a><code><span class="keyword">module</span> B' = <a href="Foo/index.html#module-B">Foo.B</a></code>
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/test/html/expect/test_package+re/Recent_impl/index.html b/test/html/expect/test_package+re/Recent_impl/index.html
new file mode 100644
index 0000000..25fc729
--- /dev/null
+++ b/test/html/expect/test_package+re/Recent_impl/index.html
@@ -0,0 +1,44 @@
+<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+ Recent_impl (test_package+re.Recent_impl)
+ </title>
+ <link rel="stylesheet" href="../../odoc.css">
+ <meta charset="utf-8">
+ <meta name="generator" content="odoc %%VERSION%%">
+ <meta name="viewport" content="width=device-width,initial-scale=1.0">
+ <script src="../../highlight.pack.js"></script>
+ <script>
+ hljs.initHighlightingOnLoad();
+ </script>
+ </head>
+ <body>
+ <div class="content">
+ <header>
+ <nav>
+ <a href="../index.html">Up</a> – <a href="../index.html">test_package+re</a> » Recent_impl
+ </nav>
+ <h1>
+ Module <code>Recent_impl</code>
+ </h1>
+ </header>
+ <div class="spec module" id="module-Foo">
+ <a href="#module-Foo" class="anchor"></a><code><span class="keyword">module</span> <a href="Foo/index.html">Foo</a>: { ... };</code>
+ </div>
+ <div class="spec module" id="module-B">
+ <a href="#module-B" class="anchor"></a><code><span class="keyword">module</span> B = <a href="$Open__10_123/index.html#module-$B">$B</a>;</code>
+ </div>
+ <dl>
+ <dt class="spec type" id="type-u">
+ <a href="#type-u" class="anchor"></a><code><span class="keyword">type</span> u</code><code> = <a href="$Open__14_193/index.html#type-$t">$t</a></code>;
+ </dt>
+ </dl>
+ <div class="spec module-type" id="module-type-S">
+ <a href="#module-type-S" class="anchor"></a><code><span class="keyword">module</span> <span class="keyword">type</span> <a href="module-type-S/index.html">S</a> = { ... };</code>
+ </div>
+ <div class="spec module" id="module-B'">
+ <a href="#module-B'" class="anchor"></a><code><span class="keyword">module</span> B' = <a href="Foo/index.html#module-B">Foo.B</a>;</code>
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/test/html/test.ml b/test/html/test.ml
index 168e884..0d24097 100644
--- a/test/html/test.ml
+++ b/test/html/test.ml
@@ -285,7 +285,9 @@ let source_files = [
let source_files =
let latest_supported = "4.08." in
match String.sub (Sys.ocaml_version) 0 (String.length latest_supported) with
- | s when s = latest_supported -> source_files @ [("recent.mli", ["Recent/index.html"; "Recent/X/index.html"])]
+ | s when s = latest_supported -> source_files @
+ [ ("recent.mli", ["Recent/index.html"; "Recent/X/index.html"])
+ ; ("recent_impl.ml", ["Recent_impl/index.html"])]
| _ -> source_files
| exception _ -> source_files
--
2.24.1

1115
0003-4.10-compatibility-408.patch Normal file
View File

File diff suppressed because it is too large Load Diff

14
ocaml-odoc.spec
View File

@ -12,6 +12,15 @@ Summary: Documentation compiler for OCaml and Reason
License: MIT
URL: https://github.com/ocaml/odoc
Source0: %{url}/archive/%{version}/%{srcname}-%{version}.tar.gz
# Emit quote before identifier in alias type expressions
# https://github.com/ocaml/odoc/commit/acf7732ec95332b4589eea397409d02cfb8867d3
Patch0: 0001-Emit-quote-before-identifier-in-alias-type-exprs.patch
# Handle generalized open statements
# https://github.com/ocaml/odoc/commit/152481881b26873d6890519a8e8c15b35f6819bf
Patch1: 0002-Handle-generalized-open-statements-393.patch
# Be compatible with OCaml 4.10
# https://github.com/ocaml/odoc/commit/35f5619a021944cda5ef495096651a70f49fdedc
Patch2: 0003-4.10-compatibility-408.patch
BuildRequires: ocaml >= 4.02.0
BuildRequires: ocaml-alcotest-devel >= 0.8.3
@ -59,7 +68,7 @@ BuildArch: noarch
Documentation for %{name}.
%prep
%autosetup -n %{srcname}-%{version}
%autosetup -n %{srcname}-%{version} -p1
# The opam file has not been updated since the great renumbering.
sed -i 's/113\.33\.00/0.13.0/' odoc.opam
@ -138,6 +147,9 @@ dune runtest
%license LICENSE.md
%changelog
* Sat Feb 1 2020 Jerry James <loganjerry@gmail.com> - 1.4.2-3
- Add 3 patches for OCaml 4.10 compatibility
* Wed Jan 29 2020 Fedora Release Engineering <releng@fedoraproject.org> - 1.4.2-3
- Rebuilt for https://fedoraproject.org/wiki/Fedora_32_Mass_Rebuild