From 35f5619a021944cda5ef495096651a70f49fdedc Mon Sep 17 00:00:00 2001
From: Jon Ludlam <jon@recoil.org>
Date: Fri, 31 Jan 2020 17:02:01 +0000
Subject: [PATCH] 4.10 compatibility (#408)
* OCaml 4.10 compatibility
Signed-off-by: Jon Ludlam <jon@recoil.org>
---
src/html/generator.ml | 16 ++--
src/html/targets.ml | 8 +-
src/loader/cmi.ml | 22 +++---
src/loader/cmt.ml | 74 +++++++++++++++----
src/loader/cmti.ml | 66 ++++++++++++++---
src/model/compat.cppo.ml | 67 +++++++++++++++--
src/model/ident_env.cppo.ml | 35 ++++++++-
src/model/lang.ml | 14 ++--
src/model/maps.ml | 16 ++--
src/model/maps.mli | 8 +-
src/xref/component_table.ml | 6 +-
src/xref/expand.ml | 37 +++++-----
src/xref/name_env.ml | 4 +-
src/xref/resolve.ml | 12 +--
test/html/cases/bugs.ml | 5 --
test/html/cases/bugs_pre_410.ml | 6 ++
.../expect/test_package+ml/Bugs/index.html | 15 ----
.../test_package+ml/Bugs_pre_410/index.html | 42 +++++++++++
.../expect/test_package+re/Bugs/index.html | 15 ----
.../test_package+re/Bugs_pre_410/index.html | 42 +++++++++++
test/html/test.ml | 28 ++++---
21 files changed, 389 insertions(+), 149 deletions(-)
create mode 100644 test/html/cases/bugs_pre_410.ml
create mode 100644 test/html/expect/test_package+ml/Bugs_pre_410/index.html
create mode 100644 test/html/expect/test_package+re/Bugs_pre_410/index.html
diff --git a/src/html/generator.ml b/src/html/generator.ml
index fd96630..b8b6606 100644
--- a/src/html/generator.ml
+++ b/src/html/generator.ml
@@ -25,7 +25,7 @@ open Utils
let a_href = Tree.Relative_link.to_sub_element
-let functor_arg_pos { Odoc_model.Lang.FunctorArgument.id ; _ } =
+let functor_arg_pos { Odoc_model.Lang.FunctorParameter.id ; _ } =
match id with
| `Argument (_, nb, _) -> nb
| _ ->
@@ -1462,10 +1462,10 @@ struct
tagged_items
and functor_argument
- : 'row. ?theme_uri:Tree.uri -> Odoc_model.Lang.FunctorArgument.t
+ : 'row. ?theme_uri:Tree.uri -> Odoc_model.Lang.FunctorParameter.parameter
-> Html_types.div_content Html.elt list * Tree.t list
= fun ?theme_uri arg ->
- let open Odoc_model.Lang.FunctorArgument in
+ let open Odoc_model.Lang.FunctorParameter in
let name = Paths.Identifier.name arg.id in
let nb = functor_arg_pos arg in
let link_name = Printf.sprintf "%d-%s" nb name in
@@ -1515,8 +1515,8 @@ struct
let params, params_subpages =
List.fold_left (fun (args, subpages as acc) arg ->
match arg with
- | None -> acc
- | Some arg ->
+ | Odoc_model.Lang.FunctorParameter.Unit -> acc
+ | Named arg ->
let arg, arg_subpages = functor_argument ?theme_uri arg in
let arg = Html.li arg in
(args @ [arg], subpages @ arg_subpages)
@@ -1666,13 +1666,13 @@ struct
Html.txt " ... ";
Syntax.Mod.close_tag;
]
- | Functor (None, expr) ->
+ | Functor (Unit, expr) ->
(if Syntax.Mod.functor_keyword then [keyword "functor"] else []) @
Html.txt " () " ::
mty base expr
- | Functor (Some arg, expr) ->
+ | Functor (Named arg, expr) ->
let name =
- let open Odoc_model.Lang.FunctorArgument in
+ let open Odoc_model.Lang.FunctorParameter in
let to_print = Html.txt @@ Paths.Identifier.name arg.id in
match
Tree.Relative_link.Id.href
diff --git a/src/html/targets.ml b/src/html/targets.ml
index c7f333c..26d90f4 100644
--- a/src/html/targets.ml
+++ b/src/html/targets.ml
@@ -17,7 +17,7 @@
open StdLabels
open Odoc_model.Paths
-let functor_arg_pos { Odoc_model.Lang.FunctorArgument.id ; _ } =
+let functor_arg_pos { Odoc_model.Lang.FunctorParameter.id ; _ } =
match id with
| `Argument (_, nb, _) -> nb
| _ ->
@@ -63,7 +63,7 @@ and signature ~prefix (t : Odoc_model.Lang.Signature.t) =
add_items ~don't:false [] t
and functor_argument ~prefix arg =
- let open Odoc_model.Lang.FunctorArgument in
+ let open Odoc_model.Lang.FunctorParameter in
match arg.expansion with
| None -> []
| Some expansion ->
@@ -82,8 +82,8 @@ and module_expansion ~prefix (t : Odoc_model.Lang.Module.expansion) =
let subpages = signature ~prefix sg in
List.fold_left args ~init:subpages ~f:(fun subpages arg ->
match arg with
- | None -> subpages
- | Some arg ->
+ | Odoc_model.Lang.FunctorParameter.Unit -> subpages
+ | Named arg ->
let arg_subpages = functor_argument ~prefix arg in
arg_subpages @ subpages
)
diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml
index 05f24eb..21059ba 100644
--- a/src/loader/cmi.ml
+++ b/src/loader/cmi.ml
@@ -837,12 +837,15 @@ let rec read_module_type env parent pos (mty : Odoc_model.Compat.module_type) =
match mty with
| Mty_ident p -> Path (Env.Path.read_module_type env p)
| Mty_signature sg -> Signature (read_signature env parent sg)
- | Mty_functor(id, arg, res) ->
- let arg =
- match arg with
- | None -> None
- | Some arg ->
- let name = parenthesise (Ident.name id) in
+ | Mty_functor(parameter, res) ->
+ let parameter, env =
+ match parameter with
+ | Unit -> Odoc_model.Lang.FunctorParameter.Unit, env
+ | Named (id_opt, arg) ->
+ let name, env = match id_opt with
+ | Some id -> parenthesise (Ident.name id), Env.add_argument parent pos id (ArgumentName.of_ident id) env
+ | None -> "_", env
+ in
let id = `Argument(parent, pos, Odoc_model.Names.ArgumentName.of_string name) in
let arg = read_module_type env id 1 arg in
let expansion =
@@ -850,11 +853,10 @@ let rec read_module_type env parent pos (mty : Odoc_model.Compat.module_type) =
| Signature _ -> Some Module.AlreadyASig
| _ -> None
in
- Some { FunctorArgument. id; expr = arg; expansion }
+ Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg; expansion }), 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)
+ let res = read_module_type env parent (pos+1) res in
+ Functor(parameter, res)
| Mty_alias _ -> assert false
and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) =
diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml
index 892959a..34cfb16 100644
--- a/src/loader/cmt.ml
+++ b/src/loader/cmt.ml
@@ -357,24 +357,48 @@ let rec read_module_expr env parent label_parent pos mexpr =
| Tmod_ident _ ->
Cmi.read_module_type env parent pos (Odoc_model.Compat.module_type mexpr.mod_type)
| Tmod_structure str -> Signature (read_structure env parent str)
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ | Tmod_functor(parameter, res) ->
+ let parameter, env =
+ match parameter with
+ | Unit -> FunctorParameter.Unit, env
+ | Named (id_opt, _, arg) ->
+ let name, env =
+ match id_opt with
+ | Some id -> parenthesise (Ident.name id), Env.add_argument parent pos id (ArgumentName.of_ident id) env
+ | None -> "_", env
+ in
+ let id = `Argument(parent, pos, Odoc_model.Names.ArgumentName.of_string name) in
+ let arg = Cmti.read_module_type env id label_parent 1 arg in
+ let expansion =
+ match arg with
+ | Signature _ -> Some Module.AlreadyASig
+ | _ -> None
+ in
+ Named { id; expr=arg; expansion}, env
+ in
+ let res = read_module_expr env parent label_parent (pos + 1) res in
+ Functor(parameter, res)
+#else
| Tmod_functor(id, _, arg, res) ->
let arg =
match arg with
- | None -> None
+ | None -> FunctorParameter.Unit
| Some arg ->
let name = parenthesise (Ident.name id) in
let id = `Argument(parent, pos, ArgumentName.of_string name) in
let arg = Cmti.read_module_type env id label_parent 1 arg in
- let expansion =
- match arg with
- | Signature _ -> Some Module.AlreadyASig
- | _ -> None
- in
- Some { FunctorArgument. id; expr = arg; expansion }
+ let expansion =
+ match arg with
+ | Signature _ -> Some Module.AlreadyASig
+ | _ -> None
+ in
+ Named { FunctorParameter. id; expr = arg; expansion }
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)
+#endif
| Tmod_apply _ ->
Cmi.read_module_type env parent pos (Odoc_model.Compat.module_type mexpr.mod_type)
| Tmod_constraint(_, _, Tmodtype_explicit mty, _) ->
@@ -392,8 +416,16 @@ and unwrap_module_expr_desc = function
and read_module_binding env parent mb =
let open Module in
let open Odoc_model.Names in
- let name = parenthesise (Ident.name mb.mb_id) in
- let id = `Module(parent, ModuleName.of_string name) in
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ match mb.mb_id with
+ | None -> None
+ | Some id ->
+ let name = parenthesise (Ident.name id) in
+ let id = `Module(parent, ModuleName.of_string name) in
+#else
+ let name = parenthesise (Ident.name mb.mb_id) in
+ let id = `Module(parent, ModuleName.of_string name) in
+#endif
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
let doc = Doc_attr.attached container mb.mb_attributes in
let canonical =
@@ -409,16 +441,22 @@ and read_module_binding env parent mb =
| _ -> ModuleType (read_module_expr env id container 1 mb.mb_expr)
in
let hidden =
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ match canonical, mb.mb_id with
+ | None, Some id -> Odoc_model.Root.contains_double_underscore (Ident.name id)
+ | _, _ -> false
+#else
match canonical with
- | Some _ -> false
| None -> Odoc_model.Root.contains_double_underscore (Ident.name mb.mb_id)
+ | _ -> false
+#endif
in
let expansion =
match type_ with
| ModuleType (ModuleType.Signature _) -> Some AlreadyASig
| _ -> None
in
- {id; doc; type_; expansion; canonical; hidden; display_type = None}
+ Some {id; doc; type_; expansion; canonical; hidden; display_type = None}
and read_module_bindings env parent mbs =
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t)
@@ -428,8 +466,10 @@ and read_module_bindings env parent mbs =
(fun (acc, recursive) mb ->
let comments = Doc_attr.standalone_multiple container mb.mb_attributes in
let comments = List.map (fun com -> Comment com) comments in
- let mb = read_module_binding env parent mb in
- ((Module (recursive, mb))::(List.rev_append comments acc), And))
+ match read_module_binding env parent mb with
+ | Some mb ->
+ ((Module (recursive, mb))::(List.rev_append comments acc), And)
+ | None -> (acc, recursive))
([], Rec) mbs
|> fst
|> List.rev
@@ -484,8 +524,12 @@ and read_structure_item env parent item =
#endif
in
[Exception ext]
- | Tstr_module mb ->
- [Module (Ordinary, read_module_binding env parent mb)]
+ | Tstr_module mb -> begin
+ match read_module_binding env parent mb with
+ | Some mb ->
+ [Module (Ordinary, mb)]
+ | None -> []
+ end
| Tstr_recmodule mbs ->
read_module_bindings env parent mbs
| Tstr_modtype mtd ->
diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml
index 13afb84..85ae9c2 100644
--- a/src/loader/cmti.ml
+++ b/src/loader/cmti.ml
@@ -477,24 +477,49 @@ and read_module_type env parent label_parent pos mty =
match mty.mty_desc with
| Tmty_ident(p, _) -> Path (Env.Path.read_module_type env p)
| Tmty_signature sg -> Signature (read_signature env parent sg)
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ | Tmty_functor(parameter, res) ->
+ let parameter, env =
+ match parameter with
+ | Unit -> FunctorParameter.Unit, env
+ | Named (id_opt, _, arg) ->
+ let name, env =
+ match id_opt with
+ | Some id ->
+ parenthesise (Ident.name id), Env.add_argument parent pos id (ArgumentName.of_ident id) env
+ | None -> "_", env
+ in
+ let id = `Argument(parent, pos, ArgumentName.of_string name) in
+ let arg = read_module_type env id label_parent 1 arg in
+ let expansion =
+ match arg with
+ | Signature _ -> Some Module.AlreadyASig
+ | _ -> None
+ in
+ Named { id; expr = arg; expansion }, env
+ in
+ let res = read_module_type env parent label_parent (pos + 1) res in
+ Functor(parameter, res)
+#else
| Tmty_functor(id, _, arg, res) ->
let arg =
match arg with
- | None -> None
+ | None -> Odoc_model.Lang.FunctorParameter.Unit
| Some arg ->
let name = parenthesise (Ident.name id) in
let id = `Argument(parent, pos, Odoc_model.Names.ArgumentName.of_string name) in
- let arg = read_module_type env id label_parent 1 arg in
+ let arg = read_module_type env id label_parent 1 arg in
let expansion =
match arg with
| Signature _ -> Some Module.AlreadyASig
| _ -> None
in
- Some { FunctorArgument. id; expr = arg; expansion }
+ Named { FunctorParameter. id; expr = arg; expansion }
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)
+ let res = read_module_type env parent label_parent (pos + 1) res in
+ Functor(arg, res)
+#endif
| Tmty_with(body, subs) ->
let body = read_module_type env parent label_parent pos body in
let subs = List.map (read_with_constraint env label_parent) subs in
@@ -529,8 +554,17 @@ and read_module_type_declaration env parent mtd =
and read_module_declaration env parent md =
let open Module in
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ match md.md_id with
+ | None -> None
+ | Some id ->
+ let name = parenthesise (Ident.name id) in
+ let id = `Module(parent, Odoc_model.Names.ModuleName.of_string name) in
+#else
let name = parenthesise (Ident.name md.md_id) in
let id = `Module(parent, Odoc_model.Names.ModuleName.of_string name) in
+#endif
+
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
let doc = Doc_attr.attached container md.md_attributes in
let canonical =
@@ -546,16 +580,22 @@ and read_module_declaration env parent md =
| _ -> ModuleType (read_module_type env id container 1 md.md_type)
in
let hidden =
+#if OCAML_MAJOR=4 && OCAML_MINOR >= 10
+ match canonical, md.md_id with
+ | None, Some id -> Odoc_model.Root.contains_double_underscore (Ident.name id)
+ | _,_ -> false
+#else
match canonical with
- | Some _ -> false
| None -> Odoc_model.Root.contains_double_underscore (Ident.name md.md_id)
+ | _ -> false
+#endif
in
let expansion =
match type_ with
| ModuleType (ModuleType.Signature _) -> Some AlreadyASig
| _ -> None
in
- {id; doc; type_; expansion; canonical; hidden; display_type = None}
+ Some {id; doc; type_; expansion; canonical; hidden; display_type = None}
and read_module_declarations env parent mds =
let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
@@ -564,8 +604,9 @@ and read_module_declarations env parent mds =
(fun (acc, recursive) md ->
let comments = Doc_attr.standalone_multiple container md.md_attributes in
let comments = List.map (fun com -> Comment com) comments in
- let md = read_module_declaration env parent md in
- ((Module (recursive, md))::(List.rev_append comments acc), And))
+ match read_module_declaration env parent md with
+ | Some md -> ((Module (recursive, md))::(List.rev_append comments acc), And)
+ | None -> acc, recursive)
([], Rec) mds
|> fst
|> List.rev
@@ -614,8 +655,11 @@ and read_signature_item env parent item =
#else
[Exception (read_exception env parent ext)]
#endif
- | Tsig_module md ->
- [Module (Ordinary, read_module_declaration env parent md)]
+ | Tsig_module md -> begin
+ match read_module_declaration env parent md with
+ | Some m -> [Module (Ordinary, m)]
+ | None -> []
+ end
| Tsig_recmodule mds ->
read_module_declarations env parent mds
| Tsig_modtype mtd ->
diff --git a/src/model/compat.cppo.ml b/src/model/compat.cppo.ml
index 41283f8..0bf88ef 100644
--- a/src/model/compat.cppo.ml
+++ b/src/model/compat.cppo.ml
@@ -31,9 +31,13 @@ type visibility =
type module_type =
Mty_ident of Path.t
| Mty_signature of signature
- | Mty_functor of Ident.t * module_type option * module_type
+ | Mty_functor of functor_parameter * module_type
| Mty_alias of Path.t
+and functor_parameter =
+ | Unit
+ | Named of Ident.t option * module_type
+
and module_presence =
| Mp_present
| Mp_absent
@@ -67,7 +71,48 @@ and modtype_declaration =
let opt conv = function | None -> None | Some x -> Some (conv x)
-#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+
+let rec signature : Types.signature -> signature = fun x -> List.map signature_item x
+
+and signature_item : Types.signature_item -> signature_item = function
+ | Types.Sig_value (a,b,c) -> Sig_value (a,b,visibility c)
+ | Types.Sig_type (a,b,c,d) -> Sig_type (a,b,c, visibility d)
+ | Types.Sig_typext (a,b,c,d) -> Sig_typext (a,b,c,visibility d)
+ | Types.Sig_module (a,b,c,d,e) -> Sig_module (a, module_presence b, module_declaration c, d, visibility e)
+ | Types.Sig_modtype (a,b,c) -> Sig_modtype (a, modtype_declaration b, visibility c)
+ | Types.Sig_class (a,b,c,d) -> Sig_class (a,b,c, visibility d)
+ | Types.Sig_class_type (a,b,c,d) -> Sig_class_type (a,b,c, visibility d)
+
+and visibility : Types.visibility -> visibility = function
+ | Types.Hidden -> Hidden
+ | Types.Exported -> Exported
+
+and module_type : Types.module_type -> module_type = function
+ | Types.Mty_ident p -> Mty_ident p
+ | Types.Mty_signature s -> Mty_signature (signature s)
+ | Types.Mty_functor (a, b) -> Mty_functor(functor_parameter a, module_type b)
+ | Types.Mty_alias p -> Mty_alias p
+
+and functor_parameter : Types.functor_parameter -> functor_parameter = function
+ | Types.Unit -> Unit
+ | Types.Named (a,b) -> Named (a, module_type b)
+
+and module_presence : Types.module_presence -> module_presence = function
+ | Types.Mp_present -> Mp_present
+ | Types.Mp_absent -> Mp_absent
+
+and module_declaration : Types.module_declaration -> module_declaration = fun x ->
+ { md_type = module_type x.Types.md_type;
+ md_attributes = x.md_attributes;
+ md_loc = x.md_loc }
+
+and modtype_declaration : Types.modtype_declaration -> modtype_declaration = fun x ->
+ { mtd_type = opt module_type x.Types.mtd_type;
+ mtd_attributes = x.Types.mtd_attributes;
+ mtd_loc = x.Types.mtd_loc }
+
+#elif OCAML_MAJOR = 4 && OCAML_MINOR >= 08
let rec signature : Types.signature -> signature = fun x -> List.map signature_item x
@@ -87,7 +132,11 @@ and visibility : Types.visibility -> visibility = function
and module_type : Types.module_type -> module_type = function
| Types.Mty_ident p -> Mty_ident p
| Types.Mty_signature s -> Mty_signature (signature s)
- | Types.Mty_functor (a, b, c) -> Mty_functor(a, opt module_type b, module_type c)
+ | Types.Mty_functor (a, b, c) -> begin
+ match b with
+ | Some m -> Mty_functor(Named(Some a,module_type m),module_type c)
+ | None -> Mty_functor(Unit,module_type c)
+ end
| Types.Mty_alias p -> Mty_alias p
and module_presence : Types.module_presence -> module_presence = function
@@ -109,7 +158,11 @@ and modtype_declaration : Types.modtype_declaration -> modtype_declaration = fun
let rec module_type : Types.module_type -> module_type = function
| Types.Mty_ident p -> Mty_ident p
| Types.Mty_signature s -> Mty_signature (signature s)
- | Types.Mty_functor (a, b, c) -> Mty_functor(a, opt module_type b, module_type c)
+ | Types.Mty_functor (a, b, c) -> begin
+ match b with
+ | Some m -> Mty_functor(Named(Some a,module_type m),module_type c)
+ | None -> Mty_functor(Unit,module_type c)
+ end
| Types.Mty_alias (_,q) -> Mty_alias q
and signature_item : Types.signature_item -> signature_item = function
@@ -140,7 +193,11 @@ and modtype_declaration : Types.modtype_declaration -> modtype_declaration = fun
let rec module_type : Types.module_type -> module_type = function
| Types.Mty_ident p -> Mty_ident p
| Types.Mty_signature s -> Mty_signature (signature s)
- | Types.Mty_functor (a, b, c) -> Mty_functor(a, opt module_type b, module_type c)
+ | Types.Mty_functor (a, b, c) -> begin
+ match b with
+ | Some m -> Mty_functor(Named(Some a,module_type m),module_type c)
+ | None -> Mty_functor(Unit,module_type c)
+ end
| Types.Mty_alias q -> Mty_alias q
and signature_item : Types.signature_item -> signature_item = function
diff --git a/src/model/ident_env.cppo.ml b/src/model/ident_env.cppo.ml
index 1534ecf..0d25301 100644
--- a/src/model/ident_env.cppo.ml
+++ b/src/model/ident_env.cppo.ml
@@ -185,12 +185,27 @@ let add_signature_tree_item parent item env =
List.fold_right
(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 (ModuleName.of_ident md.md_id) env
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ | Tsig_module { md_id = Some id; _ } ->
+ add_module parent id (ModuleName.of_ident id) env
+ | Tsig_module _ ->
+ env
| Tsig_recmodule mds ->
List.fold_right
- (fun md env -> add_module parent md.md_id (ModuleName.of_ident md.md_id) env)
+ (fun md env ->
+ match md.md_id with
+ | Some id -> add_module parent id (ModuleName.of_ident id) env
+ | None -> env)
mds env
+#else
+ | Tsig_module { md_id; _ } ->
+ add_module parent md_id (ModuleName.of_ident md_id) env
+ | Tsig_recmodule mds ->
+ List.fold_right
+ (fun md env ->
+ add_module parent md.md_id (ModuleName.of_ident md.md_id) env)
+ mds env
+#endif
| Tsig_modtype mtd ->
add_module_type parent mtd.mtd_id (ModuleTypeName.of_ident mtd.mtd_id) env
| Tsig_include incl ->
@@ -250,11 +265,23 @@ let add_structure_tree_item parent item env =
List.fold_right
(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 (ModuleName.of_ident mb.mb_id) env
+#if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
+ | Tstr_module { mb_id = Some id; _} -> add_module parent id (ModuleName.of_ident id) env
+ | Tstr_module _ -> env
+ | Tstr_recmodule mbs ->
+ List.fold_right
+ (fun mb env ->
+ match mb.mb_id with
+ | Some id -> add_module parent id (ModuleName.of_ident id) env
+ | None -> env)
+ mbs env
+#else
+ | Tstr_module { mb_id; _} -> add_module parent mb_id (ModuleName.of_ident mb_id) env
| Tstr_recmodule mbs ->
List.fold_right
(fun mb env -> add_module parent mb.mb_id (ModuleName.of_ident mb.mb_id) env)
mbs env
+#endif
| Tstr_modtype mtd ->
add_module_type parent mtd.mtd_id (ModuleTypeName.of_ident mtd.mtd_id) env
| Tstr_include incl ->
diff --git a/src/model/lang.ml b/src/model/lang.ml
index 3f8b86e..914d360 100644
--- a/src/model/lang.ml
+++ b/src/model/lang.ml
@@ -23,7 +23,7 @@ module rec Module : sig
type expansion =
| AlreadyASig
| Signature of Signature.t
- | Functor of FunctorArgument.t option list * Signature.t
+ | Functor of FunctorParameter.t list * Signature.t
type decl =
| Alias of Path.Module.t
@@ -47,13 +47,17 @@ module rec Module : sig
end = Module
-and FunctorArgument : sig
- type t = {
+and FunctorParameter : sig
+ type parameter = {
id : Identifier.Module.t;
expr : ModuleType.expr;
expansion: Module.expansion option;
}
-end = FunctorArgument
+
+ type t =
+ | Unit
+ | Named of parameter
+end = FunctorParameter
(** {3 Modules Types} *)
@@ -68,7 +72,7 @@ and ModuleType : sig
type expr =
| Path of Path.ModuleType.t
| Signature of Signature.t
- | Functor of FunctorArgument.t option * expr
+ | Functor of FunctorParameter.t * expr
| With of expr * substitution list
| TypeOf of Module.decl
diff --git a/src/model/maps.ml b/src/model/maps.ml
index dac8178..0bad09c 100644
--- a/src/model/maps.ml
+++ b/src/model/maps.ml
@@ -1119,8 +1119,8 @@ class virtual module_ = object (self)
method virtual signature : Signature.t -> Signature.t
- method virtual module_type_functor_arg :
- FunctorArgument.t option -> FunctorArgument.t option
+ method virtual module_type_functor_param :
+ FunctorParameter.t -> FunctorParameter.t
method module_hidden h = h
@@ -1133,7 +1133,7 @@ class virtual module_ = object (self)
if sg != sg' then Signature sg'
else expn
| Functor (args, sg) ->
- let args' = list_map self#module_type_functor_arg args in
+ let args' = list_map self#module_type_functor_param args in
let sg' = self#signature sg in
if args != args' || sg != sg' then Functor(args', sg')
else expn
@@ -1278,7 +1278,7 @@ class virtual module_type = object (self)
if sg != sg' then Signature sg'
else expr
| Functor(arg, res) ->
- let arg' = self#module_type_functor_arg arg in
+ let arg' = self#module_type_functor_param arg in
let res' = self#module_type_expr res in
if arg != arg' || res != res' then Functor(arg', res')
else expr
@@ -1292,15 +1292,15 @@ class virtual module_type = object (self)
if decl != decl' then TypeOf decl'
else expr
- method module_type_functor_arg arg =
+ method module_type_functor_param arg =
match arg with
- | None -> arg
- | Some { FunctorArgument. id; expr; expansion } ->
+ | Unit -> Unit
+ | Named { FunctorParameter. id; expr; expansion } ->
let id' = self#identifier_module id in
let expr' = self#module_type_expr expr in
let expansion' = option_map self#module_expansion expansion in
if id != id' || expr != expr' || expansion != expansion' then
- Some {FunctorArgument. id = id'; expr = expr'; expansion = expansion'}
+ Named {FunctorParameter. id = id'; expr = expr'; expansion = expansion'}
else arg
method module_type mty =
diff --git a/src/model/maps.mli b/src/model/maps.mli
index c3f8ead..afb1258 100644
--- a/src/model/maps.mli
+++ b/src/model/maps.mli
@@ -421,8 +421,8 @@ class virtual module_ : object
method virtual signature : Signature.t -> Signature.t
- method virtual module_type_functor_arg :
- FunctorArgument.t option -> FunctorArgument.t option
+ method virtual module_type_functor_param :
+ FunctorParameter.t -> FunctorParameter.t
method module_expansion : Module.expansion -> Module.expansion
@@ -482,8 +482,8 @@ class virtual module_type : object
method module_type_expr : ModuleType.expr -> ModuleType.expr
- method module_type_functor_arg :
- FunctorArgument.t option -> FunctorArgument.t option
+ method module_type_functor_param :
+ FunctorParameter.t -> FunctorParameter.t
method module_type : ModuleType.t -> ModuleType.t
diff --git a/src/xref/component_table.ml b/src/xref/component_table.ml
index 9407bf0..1f0710f 100644
--- a/src/xref/component_table.ml
+++ b/src/xref/component_table.ml
@@ -552,15 +552,15 @@ and signature_items local =
and module_type_expr local expr =
let open Sig in
let open ModuleType in
- let open FunctorArgument in
+ let open FunctorParameter in
match expr with
| Path p -> path (module_type_path local) p
| Signature sg -> signature (signature_items local) sg
- | Functor(Some{ id; expr = arg; _}, res) ->
+ | Functor(Named { id; expr = arg; _}, res) ->
let res = module_type_expr local res in
let arg = module_type_expr local arg in
functor_ local.t.equal local.t.hash id arg res
- | Functor(None, res) ->
+ | Functor(Unit, res) ->
let res = module_type_expr local res in
generative res
| With(body, subs) ->
diff --git a/src/xref/expand.ml b/src/xref/expand.ml
index db45fd1..672979e 100644
--- a/src/xref/expand.ml
+++ b/src/xref/expand.ml
@@ -21,7 +21,7 @@ open Names
type partial_expansion =
| Signature of Signature.t
- | Functor of FunctorArgument.t option *
+ | Functor of FunctorParameter.t *
Identifier.Signature.t * int *
ModuleType.expr
@@ -30,15 +30,16 @@ let subst_signature sub = function
| Some sg -> Some (Subst.signature sub sg)
let subst_arg sub arg =
+ let open FunctorParameter in
match arg with
- | None -> None
- | Some {FunctorArgument. id; expr; expansion} ->
+ | Unit -> Unit
+ | Named {id; expr; expansion} ->
let id' = Subst.identifier_module sub id in
let expr' = Subst.module_type_expr sub expr in
let expansion' =
Maps.option_map (Subst.module_expansion sub) expansion
in
- Some {FunctorArgument. id = id'; expr = expr'; expansion = expansion'}
+ Named {id = id'; expr = expr'; expansion = expansion'}
let subst_expansion sub = function
| None -> None
@@ -349,7 +350,7 @@ let expand_include t root incl =
| Some (Functor _) -> To_functor (* TODO: Should be an error *)
end
-let expand_argument_ t root {FunctorArgument. id; expr; expansion} =
+let expand_argument_ t root {FunctorParameter. id; expr; expansion} =
match expansion with
| None ->
let id = (id : Identifier.Module.t :> Identifier.Signature.t) in
@@ -416,8 +417,8 @@ let find_argument t root pos ex =
match ex with
| None -> raise Not_found
| Some (Signature _) -> raise Not_found
- | Some (Functor(None, _, _, _)) when pos = 1 -> raise Not_found
- | Some (Functor(Some arg, _, _, _)) when pos = 1 -> arg
+ | Some (Functor(Unit, _, _, _)) when pos = 1 -> raise Not_found
+ | Some (Functor(Named arg, _, _, _)) when pos = 1 -> arg
| Some (Functor(_, dest, offset, expr)) ->
loop t root (pos - 1) (expand_module_type_expr t root dest offset expr)
in
@@ -479,9 +480,9 @@ and expand_module_identifier' t root (id : Identifier.Module.t) =
md.id, md.doc, md.canonical, expand_module t root md, []
| `Argument(parent, pos, _name) ->
let ex = t.expand_signature_identifier ~root parent in
- let {FunctorArgument. id; _} as arg = find_argument t root pos ex in
+ let {FunctorParameter. id; _} as arg = find_argument t root pos ex in
let doc = [] in
- id, doc, None, expand_argument_ t root arg, []
+ id, doc, None, expand_argument_ t root arg, []
and expand_module_type_identifier' t root (id : Identifier.ModuleType.t) =
match id with
@@ -821,16 +822,16 @@ let rec force_expansion t root (ex : partial_expansion option) =
| Some (Module.Functor(args, sg)) ->
Some(Module.Functor(arg :: args, sg))
-and expand_argument t arg_opt =
- match arg_opt with
- | None -> arg_opt
- | Some ({FunctorArgument. id; expr; expansion} as arg) ->
+and expand_argument t arg =
+ match arg with
+ | Unit -> arg
+ | Named ({FunctorParameter. id; expr; expansion} as a) ->
match expansion with
- | Some _ -> arg_opt
+ | Some _ -> arg
| None ->
let root = Identifier.Module.root id in
- let expansion = force_expansion t root (expand_argument_ t root arg) in
- Some {FunctorArgument. id; expr; expansion}
+ let expansion = force_expansion t root (expand_argument_ t root a) in
+ Named {FunctorParameter. id; expr; expansion}
(** We will always expand modules which are not aliases. For aliases we only
expand when the thing they point to should be hidden. *)
@@ -1006,9 +1007,9 @@ class t ?equal ?hash lookup fetch = object
let incl' = expand_include t incl in
super#include_ incl'
- method! module_type_functor_arg arg =
+ method! module_type_functor_param arg =
let arg = expand_argument t arg in
- super#module_type_functor_arg arg
+ super#module_type_functor_param arg
method! class_ c =
let c' = expand_class t c in
diff --git a/src/xref/name_env.ml b/src/xref/name_env.ml
index c748728..e12d1c4 100644
--- a/src/xref/name_env.ml
+++ b/src/xref/name_env.ml
@@ -383,8 +383,8 @@ let rec add_module_type_expr_items expr env =
match expr with
| Path _ -> env
| Signature sg -> add_signature_items sg env
- | Functor(None, expr) -> add_module_type_expr_items expr env
- | Functor(Some{ FunctorArgument. id; _ }, expr) ->
+ | Functor(Unit, expr) -> add_module_type_expr_items expr env
+ | Functor(Named { FunctorParameter. id; _ }, expr) ->
add_module_ident id
(add_module_type_expr_items expr env)
| With(expr, _) -> add_module_type_expr_items expr env
diff --git a/src/xref/resolve.ml b/src/xref/resolve.ml
index 5ce721c..a647e95 100644
--- a/src/xref/resolve.ml
+++ b/src/xref/resolve.ml
@@ -2172,11 +2172,11 @@ class resolver ?equal ?hash lookup_unit fetch_unit lookup_page fetch_page =
{parent = parent'; doc = doc'; decl = decl'; expansion = expansion'}
else incl
- method! module_type_functor_arg arg =
- let open Lang.FunctorArgument in
+ method! module_type_functor_param arg =
+ let open Lang.FunctorParameter in
match arg with
- | None -> arg
- | Some{ id; expr; expansion } ->
+ | Unit -> arg
+ | Named { id; expr; expansion } ->
let id' = self#identifier_module id in
let sig_id = (id' :> Identifier.Signature.t) in
let expr' = self#module_type_expr_with_id sig_id expr in
@@ -2184,7 +2184,7 @@ class resolver ?equal ?hash lookup_unit fetch_unit lookup_page fetch_page =
Maps.option_map self#module_expansion expansion
in
if id != id' || expr != expr' || expansion != expansion' then
- Some {id = id'; expr = expr'; expansion = expansion'}
+ Named {id = id'; expr = expr'; expansion = expansion'}
else arg
method module_type_expr_with_id id expr =
@@ -2223,7 +2223,7 @@ class resolver ?equal ?hash lookup_unit fetch_unit lookup_page fetch_page =
in
With(body, substs)
| Functor(arg, res) ->
- let arg' = self#module_type_functor_arg arg in
+ let arg' = self#module_type_functor_param arg in
let res' = self#module_type_expr_with_id id res in
if res != res' || arg != arg' then Functor(arg', res')
else expr
diff --git a/test/html/cases/bugs.ml b/test/html/cases/bugs.ml
index 831c69f..2c9c30b 100644
--- a/test/html/cases/bugs.ml
+++ b/test/html/cases/bugs.ml
@@ -3,8 +3,3 @@ let foo (type a) ?(bar : a opt) () = ()
(** Triggers an assertion failure when
{:https://github.com/ocaml/odoc/issues/101} is not fixed. *)
-type 'a opt' = int option
-let foo' (type a) ?(bar : a opt') () = ()
-(** Similar to the above, but the printed type of [~bar] should be [int], not
- ['a]. This probably requires fixing in the compiler. See
- {:https://github.com/ocaml/odoc/pull/230#issuecomment-433226807}. *)
diff --git a/test/html/cases/bugs_pre_410.ml b/test/html/cases/bugs_pre_410.ml
new file mode 100644
index 0000000..0baca54
--- /dev/null
+++ b/test/html/cases/bugs_pre_410.ml
@@ -0,0 +1,6 @@
+type 'a opt' = int option
+let foo' (type a) ?(bar : a opt') () = ()
+(** Similar to [Bugs], but the printed type of [~bar] should be [int], not
+ ['a]. This probably requires fixing in the compiler. See
+ {:https://github.com/ocaml/odoc/pull/230#issuecomment-433226807}. *)
+
diff --git a/test/html/expect/test_package+ml/Bugs/index.html b/test/html/expect/test_package+ml/Bugs/index.html
index 6ab1ee7..1325131 100644
--- a/test/html/expect/test_package+ml/Bugs/index.html
+++ b/test/html/expect/test_package+ml/Bugs/index.html
@@ -37,21 +37,6 @@
</p>
</dd>
</dl>
- <dl>
- <dt class="spec type" id="type-opt'">
- <a href="#type-opt'" class="anchor"></a><code><span class="keyword">type</span> <span>'a opt'</span></code><code> = <span>int option</span></code>
- </dt>
- </dl>
- <dl>
- <dt class="spec value" id="val-foo'">
- <a href="#val-foo'" class="anchor"></a><code><span class="keyword">val</span> foo' : <span>?bar:<span class="type-var">'a</span></span> <span>-></span> unit <span>-></span> unit</code>
- </dt>
- <dd>
- <p>
- Similar to the above, but the printed type of <code>~bar</code> should be <code>int</code>, not <code>'a</code>. This probably requires fixing in the compiler. See <a href="https://github.com/ocaml/odoc/pull/230#issuecomment-433226807">https://github.com/ocaml/odoc/pull/230#issuecomment-433226807</a>.
- </p>
- </dd>
- </dl>
</div>
</body>
</html>
diff --git a/test/html/expect/test_package+ml/Bugs_pre_410/index.html b/test/html/expect/test_package+ml/Bugs_pre_410/index.html
new file mode 100644
index 0000000..1470bcc
--- /dev/null
+++ b/test/html/expect/test_package+ml/Bugs_pre_410/index.html
@@ -0,0 +1,42 @@
+<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+ Bugs_pre_410 (test_package+ml.Bugs_pre_410)
+ </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> » Bugs_pre_410
+ </nav>
+ <h1>
+ Module <code>Bugs_pre_410</code>
+ </h1>
+ </header>
+ <dl>
+ <dt class="spec type" id="type-opt'">
+ <a href="#type-opt'" class="anchor"></a><code><span class="keyword">type</span> <span>'a opt'</span></code><code> = <span>int option</span></code>
+ </dt>
+ </dl>
+ <dl>
+ <dt class="spec value" id="val-foo'">
+ <a href="#val-foo'" class="anchor"></a><code><span class="keyword">val</span> foo' : <span>?bar:<span class="type-var">'a</span></span> <span>-></span> unit <span>-></span> unit</code>
+ </dt>
+ <dd>
+ <p>
+ Similar to <code>Bugs</code>, but the printed type of <code>~bar</code> should be <code>int</code>, not <code>'a</code>. This probably requires fixing in the compiler. See <a href="https://github.com/ocaml/odoc/pull/230#issuecomment-433226807">https://github.com/ocaml/odoc/pull/230#issuecomment-433226807</a>.
+ </p>
+ </dd>
+ </dl>
+ </div>
+ </body>
+</html>
diff --git a/test/html/expect/test_package+re/Bugs/index.html b/test/html/expect/test_package+re/Bugs/index.html
index ddfcabc..4b1ebbe 100644
--- a/test/html/expect/test_package+re/Bugs/index.html
+++ b/test/html/expect/test_package+re/Bugs/index.html
@@ -37,21 +37,6 @@
</p>
</dd>
</dl>
- <dl>
- <dt class="spec type" id="type-opt'">
- <a href="#type-opt'" class="anchor"></a><code><span class="keyword">type</span> opt'('a)</code><code> = option(int)</code>;
- </dt>
- </dl>
- <dl>
- <dt class="spec value" id="val-foo'">
- <a href="#val-foo'" class="anchor"></a><code><span class="keyword">let</span> foo': <span>?bar:<span class="type-var">'a</span></span> <span>=></span> unit <span>=></span> unit;</code>
- </dt>
- <dd>
- <p>
- Similar to the above, but the printed type of <code>~bar</code> should be <code>int</code>, not <code>'a</code>. This probably requires fixing in the compiler. See <a href="https://github.com/ocaml/odoc/pull/230#issuecomment-433226807">https://github.com/ocaml/odoc/pull/230#issuecomment-433226807</a>.
- </p>
- </dd>
- </dl>
</div>
</body>
</html>
diff --git a/test/html/expect/test_package+re/Bugs_pre_410/index.html b/test/html/expect/test_package+re/Bugs_pre_410/index.html
new file mode 100644
index 0000000..7dfc7f4
--- /dev/null
+++ b/test/html/expect/test_package+re/Bugs_pre_410/index.html
@@ -0,0 +1,42 @@
+<!DOCTYPE html><html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+ Bugs_pre_410 (test_package+re.Bugs_pre_410)
+ </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> » Bugs_pre_410
+ </nav>
+ <h1>
+ Module <code>Bugs_pre_410</code>
+ </h1>
+ </header>
+ <dl>
+ <dt class="spec type" id="type-opt'">
+ <a href="#type-opt'" class="anchor"></a><code><span class="keyword">type</span> opt'('a)</code><code> = option(int)</code>;
+ </dt>
+ </dl>
+ <dl>
+ <dt class="spec value" id="val-foo'">
+ <a href="#val-foo'" class="anchor"></a><code><span class="keyword">let</span> foo': <span>?bar:<span class="type-var">'a</span></span> <span>=></span> unit <span>=></span> unit;</code>
+ </dt>
+ <dd>
+ <p>
+ Similar to <code>Bugs</code>, but the printed type of <code>~bar</code> should be <code>int</code>, not <code>'a</code>. This probably requires fixing in the compiler. See <a href="https://github.com/ocaml/odoc/pull/230#issuecomment-433226807">https://github.com/ocaml/odoc/pull/230#issuecomment-433226807</a>.
+ </p>
+ </dd>
+ </dl>
+ </div>
+ </body>
+</html>
diff --git a/test/html/test.ml b/test/html/test.ml
index 0d24097..b7d2f4e 100644
--- a/test/html/test.ml
+++ b/test/html/test.ml
@@ -250,8 +250,7 @@ let make_test_case ?theme_uri ?syntax case =
in
Case.name case, `Slow, run
-
-let source_files = [
+let source_files_all = [
("val.mli", ["Val/index.html"]);
("markup.mli", ["Markup/index.html"]);
("section.mli", ["Section/index.html"]);
@@ -279,18 +278,25 @@ let source_files = [
("alias.ml", [
"Alias/index.html";
"Alias/X/index.html";
- ]);
+ ])
]
-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"])
- ; ("recent_impl.ml", ["Recent_impl/index.html"])]
- | _ -> source_files
- | exception _ -> source_files
+let source_files_post408 =
+ [ ("recent.mli", ["Recent/index.html"; "Recent/X/index.html"])
+ ; ("recent_impl.ml", ["Recent_impl/index.html"]) ]
+let source_files_pre410 =
+ [ ("bugs_pre_410.ml", ["Bugs_pre_410/index.html"]) ]
+
+let source_files =
+ let cur = Astring.String.cuts ~sep:"." (Sys.ocaml_version) |> List.map (fun i -> try Some (int_of_string i) with _ -> None) in
+ match cur with
+ | Some major :: Some minor :: _ ->
+ List.concat
+ [ (if major=4 && minor<10 then source_files_pre410 else [])
+ ; (if major=4 && minor>8 then source_files_post408 else [])
+ ; source_files_all ]
+ | _ -> source_files_all
let () =
Env.init ();
--
2.24.1