Dot constructors are now typed

Author: jonludlam

src/document/generator.ml

@@ -110,11 +110,20 @@ module Make (Syntax : SYNTAX) = struct
       | `SubstitutedMT m -> from_path (m :> Path.t)
       | `SubstitutedT m -> from_path (m :> Path.t)
       | `SubstitutedCT m -> from_path (m :> Path.t)
-      | `Root root -> unresolved [ inline @@ Text root ]
+      | `Root root -> unresolved [ inline @@ Text (ModuleName.to_string root) ]
       | `Forward root -> unresolved [ inline @@ Text root ] (* FIXME *)
       | `Dot (prefix, suffix) ->
           let link = from_path (prefix :> Path.t) in
-          link ++ O.txt ("." ^ suffix)
+          link ++ O.txt ("." ^ ModuleName.to_string suffix)
+      | `DotT (prefix, suffix) ->
+          let link = from_path (prefix :> Path.t) in
+          link ++ O.txt ("." ^ TypeName.to_string suffix)
+      | `DotMT (prefix, suffix) ->
+          let link = from_path (prefix :> Path.t) in
+          link ++ O.txt ("." ^ ModuleTypeName.to_string suffix)
+      | `DotV (prefix, suffix) ->
+          let link = from_path (prefix :> Path.t) in
+          link ++ O.txt ("." ^ ValueName.to_string suffix)
       | `Apply (p1, p2) ->
           let link1 = from_path (p1 :> Path.t) in
           let link2 = from_path (p2 :> Path.t) in

src/document/url.ml

@@ -47,13 +47,19 @@ let render_path : Odoc_model.Paths.Path.t -> string =
     | `Value (p, s) -> render_resolved (p :> t) ^ "." ^ ValueName.to_string s
     | `Class (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
     | `ClassType (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
+  and dot p s =
+    render_path (p : Odoc_model.Paths.Path.Module.t :> Odoc_model.Paths.Path.t)
+    ^ "." ^ s
   and render_path : Odoc_model.Paths.Path.t -> string =
    fun x ->
     match x with
     | `Identifier (id, _) -> Identifier.name id
-    | `Root root -> root
+    | `Root root -> ModuleName.to_string root
     | `Forward root -> root
-    | `Dot (prefix, suffix) -> render_path (prefix :> t) ^ "." ^ suffix
+    | `Dot (p, s) -> dot p (ModuleName.to_string s)
+    | `DotT (p, s) -> dot p (TypeName.to_string s)
+    | `DotMT (p, s) -> dot p (ModuleTypeName.to_string s)
+    | `DotV (p, s) -> dot p (ValueName.to_string s)
     | `Apply (p1, p2) ->
         render_path (p1 :> t) ^ "(" ^ render_path (p2 :> t) ^ ")"
     | `Resolved rp -> render_resolved rp

src/loader/cmi.ml

@@ -741,7 +741,7 @@ let read_type_declaration env parent id decl =
   let doc, canonical =
     Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.type_attributes
   in
-  let canonical = (canonical :> Path.Type.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
   let params = mark_type_declaration decl in
   let manifest = opt_map (read_type_expr env) decl.type_manifest in
   let constraints = read_type_constraints env params in
@@ -985,7 +985,7 @@ and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_
   let source_loc = None in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
-  let canonical = (canonical :> Path.ModuleType.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
   let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in
   {id; source_loc; doc; canonical; expr }
 
@@ -995,7 +995,7 @@ and read_module_declaration env parent ident (md : Odoc_model.Compat.module_decl
   let source_loc = None in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container md.md_attributes in
-  let canonical = (canonical :> Path.Module.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
   let type_ =
     match md.md_type with
     | Mty_alias p -> Alias (Env.Path.read_module env p, None)

src/loader/cmt.ml

@@ -453,7 +453,7 @@ and read_module_binding env parent mb =
         in
         (ModuleType expr, canonical)
   in
-  let canonical = (canonical :> Path.Module.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
   let hidden =
 #if OCAML_VERSION >= (4,10,0)
     match canonical, mid.iv with
@@ -613,6 +613,7 @@ let read_implementation root name impl =
   let sg, canonical =
     read_structure Odoc_model.Semantics.Expect_canonical (Env.empty ()) id impl
   in
-  (id, sg, (canonical :> Odoc_model.Paths.Path.Module.t option))
+  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
+  (id, sg, canonical)
 
 let _ = Cmti.read_module_expr := read_module_expr

src/loader/cmti.ml

@@ -267,7 +267,7 @@ let read_type_declaration env parent decl =
   let source_loc = None in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in
-  let canonical = (canonical :> Path.Type.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
   let equation = read_type_equation env container decl in
   let representation = read_type_kind env id decl.typ_kind in
   {id; source_loc; doc; canonical; equation; representation}
@@ -608,7 +608,7 @@ and read_module_type_declaration env parent mtd =
         (Some expr, canonical)
     | None -> (None, canonical)
   in
-  let canonical = (canonical :> Path.ModuleType.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
   { id; source_loc; doc; canonical; expr }
 
 and read_module_declaration env parent md =
@@ -636,7 +636,7 @@ and read_module_declaration env parent md =
         in
         (ModuleType expr, canonical)
   in
-  let canonical = (canonical :> Path.Module.t option) in
+  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
   let hidden =
 #if OCAML_VERSION >= (4,10,0)
     match canonical, mid.iv with
@@ -812,4 +812,5 @@ let read_interface root name intf =
   let sg, canonical =
     read_signature Odoc_model.Semantics.Expect_canonical (Env.empty ()) id intf
   in
-  (id, sg, (canonical :> Odoc_model.Paths.Path.Module.t option))
+  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
+  (id, sg, canonical)

src/loader/doc_attr.ml

@@ -259,3 +259,15 @@ let extract_top_comment_class items =
   match items with
   | Lang.ClassSignature.Comment (`Docs doc) :: tl -> (tl, split_docs doc)
   | _ -> items, (empty,empty)
+
+let rec conv_canonical_module : Odoc_model.Reference.path -> Paths.Path.Module.t = function
+  | `Dot (parent, name) -> `Dot (conv_canonical_module parent, Names.ModuleName.make_std name)
+  | `Root name -> `Root (Names.ModuleName.make_std name)
+
+let conv_canonical_type : Odoc_model.Reference.path -> Paths.Path.Type.t option = function
+  | `Dot (parent, name) -> Some (`DotT (conv_canonical_module parent, Names.TypeName.make_std name))
+  | _ -> None
+
+let conv_canonical_module_type : Odoc_model.Reference.path -> Paths.Path.ModuleType.t option = function
+  | `Dot (parent, name) -> Some (`DotMT (conv_canonical_module parent, Names.ModuleTypeName.make_std name))
+  | _ -> None

src/loader/doc_attr.mli

@@ -70,3 +70,8 @@ val extract_top_comment_class :
 (** Extract the first comment of a class signature. Returns the remaining items. *)
 
 val read_location : Location.t -> Odoc_model.Location_.span
+
+val conv_canonical_module : Odoc_model.Reference.path -> Paths.Path.Module.t
+val conv_canonical_type : Odoc_model.Reference.path -> Paths.Path.Type.t option
+val conv_canonical_module_type :
+  Odoc_model.Reference.path -> Paths.Path.ModuleType.t option

src/loader/ident_env.cppo.ml

@@ -673,7 +673,7 @@ let is_shadowed
 module Path = struct
 
   let read_module_ident env id =
-    if Ident.persistent id then `Root (Ident.name id)
+    if Ident.persistent id then `Root (ModuleName.of_ident id)
     else
       try find_module env id
       with Not_found -> assert false
@@ -693,7 +693,7 @@ module Path = struct
     try
       `Identifier (find_class_type env id, false)
     with Not_found ->
-      `Dot(`Root "*", (Ident.name id))
+      `DotT (`Root (ModuleName.make_std "*"), (TypeName.of_ident id))
       (* TODO remove this hack once the fix for PR#6650
          is in the OCaml release *)
 
@@ -718,9 +718,9 @@ module Path = struct
   let rec read_module : t -> Path.t -> Paths.Path.Module.t = fun env -> function
     | Path.Pident id -> read_module_ident env id
 #if OCAML_VERSION >= (4,8,0)
-    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s) -> `Dot(read_module env p, ModuleName.make_std s)
 #else
-    | Path.Pdot(p, s, _) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s, _) -> `Dot(read_module env p, ModuleName.make_std s)
 #endif
     | Path.Papply(p, arg) -> `Apply(read_module env p, read_module env arg)
 #if OCAML_VERSION >= (5,1,0)
@@ -730,9 +730,9 @@ module Path = struct
   let read_module_type env = function
     | Path.Pident id -> read_module_type_ident env id
 #if OCAML_VERSION >= (4,8,0)
-    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s) -> `DotMT(read_module env p, ModuleTypeName.make_std s)
 #else
-    | Path.Pdot(p, s, _) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s, _) -> `DotMT(read_module env p, ModuleTypeName.make_std s)
 #endif
     | Path.Papply(_, _)-> assert false
 #if OCAML_VERSION >= (5,1,0)
@@ -742,9 +742,9 @@ module Path = struct
   let read_class_type env = function
     | Path.Pident id -> read_class_type_ident env id
 #if OCAML_VERSION >= (4,8,0)
-    | Path.Pdot(p, s) -> `Dot(read_module env p, strip_hash s)
+    | Path.Pdot(p, s) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
 #else
-    | Path.Pdot(p, s, _) -> `Dot(read_module env p, strip_hash s)
+    | Path.Pdot(p, s, _) -> `DotT(read_module env p, strip_hash s)
 #endif
     | Path.Papply(_, _)-> assert false
 #if OCAML_VERSION >= (5,1,0)
@@ -758,9 +758,9 @@ module Path = struct
 #endif
     | Path.Pident id -> read_type_ident env id
 #if OCAML_VERSION >= (4,8,0)
-    | Path.Pdot(p, s) -> `Dot(read_module env p, strip_hash s)
+    | Path.Pdot(p, s) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
 #else
-    | Path.Pdot(p, s, _) -> `Dot(read_module env p, strip_hash s)
+    | Path.Pdot(p, s, _) -> `DotT(read_module env p, TypeName.make_std (strip_hash s))
 #endif
     | Path.Papply(_, _)-> assert false
 #if OCAML_VERSION >= (5,1,0)
@@ -770,9 +770,9 @@ module Path = struct
   let read_value env = function
     | Path.Pident id -> read_value_ident env id
 #if OCAML_VERSION >= (4,8,0)
-    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s) -> `DotV(read_module env p, ValueName.make_std s)
 #else
-    | Path.Pdot(p, s, _) -> `Dot(read_module env p, s)
+    | Path.Pdot(p, s, _) -> `DotV(read_module env p, ValueName.make_std s)
 #endif
     | Path.Papply(_, _) -> assert false
 #if OCAML_VERSION >= (5,1,0)

src/loader/odoc_loader.ml

@@ -167,7 +167,7 @@ let read_cmt ~make_root ~parent ~filename () =
                   Odoc_model.Paths.Identifier.Mk.module_
                     (id, Odoc_model.Names.ModuleName.make_std name)
                 in
-                let path = `Root name in
+                let path = `Root (Odoc_model.Names.ModuleName.make_std name) in
                 { Odoc_model.Lang.Compilation_unit.Packed.id; path })
               items
           in

src/model/odoc_model.ml

@@ -9,3 +9,4 @@ module Error = Error
 module Location_ = Location_
 module Compat = Compat
 module Semantics = Semantics
+module Reference = Reference