Represent page and module paths

The Page_path constructor cannot represent these references
differerently:

    {!foo/module-Bar}
    {!foo/page-Bar}
    {!foo/Bar}

The constructors Module_path and Any_path are added in the different
reference types and pipeped through to Ref_tools.

This also fixes the parsing of paths as label parents and add better
error messages when the last component of a path isn't as expected.

src/document/comment.ml

@@ -59,7 +59,7 @@ module Reference = struct
         render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s
     | `Label (_, s) -> LabelName.to_string s
 
-  let render_page_path (tag, cs) =
+  let render_path (tag, cs) =
     let tag =
       match tag with
       | `TRelativePath -> "./"
@@ -74,7 +74,9 @@ module Reference = struct
     | `Resolved r -> render_resolved r
     | `Root (n, _) -> n
     | `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
-    | `Page_path p -> render_page_path p
+    | `Page_path p -> render_path p
+    | `Module_path p -> render_path p
+    | `Any_path p -> render_path p
     | `Module (p, f) ->
         render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f
     | `ModuleType (p, f) ->

src/model/paths.ml

@@ -1083,7 +1083,7 @@ module Reference = struct
   type t = Paths_types.Reference.any
 
   type tag_any = Paths_types.Reference.tag_any
-  type tag_page_path = Paths_types.Reference.tag_page_path
+  type tag_path = Paths_types.Reference.tag_path
 
   module Signature = struct
     type t = Paths_types.Reference.signature
@@ -1165,7 +1165,7 @@ module Reference = struct
     type t = Paths_types.Reference.page
   end
 
-  module PagePath = struct
-    type t = Paths_types.Reference.page_path
+  module Path = struct
+    type t = Paths_types.Reference.path
   end
 end

src/model/paths.mli

@@ -633,12 +633,12 @@ module rec Reference : sig
     type t = Paths_types.Reference.page
   end
 
-  module PagePath : sig
-    type t = Paths_types.Reference.page_path
+  module Path : sig
+    type t = Paths_types.Reference.path
   end
 
   type t = Paths_types.Reference.any
 
   type tag_any = Paths_types.Reference.tag_any
-  type tag_page_path = Paths_types.Reference.tag_page_path
+  type tag_path = Paths_types.Reference.tag_path
 end

src/model/paths_types.ml

@@ -553,7 +553,7 @@ module rec Reference : sig
 
   type tag_only_child_module = [ `TChildModule ]
 
-  type tag_page_path =
+  type tag_path =
     [ `TRelativePath (* {!identifier/} *)
     | `TAbsolutePath (* {!/identifier} *)
     | `TCurrentPackage (* {!//identifier} *) ]
@@ -597,14 +597,14 @@ module rec Reference : sig
     | `TChildPage
     | `TChildModule ]
 
-  type page_path = tag_page_path * string list
-  (** @canonical Odoc_model.Paths.Reference.PagePath.t *)
+  type path = tag_path * string list
+  (** @canonical Odoc_model.Paths.Reference.Path.t *)
 
   type signature =
     [ `Resolved of Resolved_reference.signature
     | `Root of string * tag_signature
     | `Dot of label_parent * string
-    | `Page_path of page_path
+    | `Module_path of path
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t ]
   (** @canonical Odoc_model.Paths.Reference.Signature.t *)
@@ -629,6 +629,7 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.field_parent
     | `Root of string * tag_parent
     | `Dot of label_parent * string
+    | `Module_path of path
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t ]
@@ -638,7 +639,9 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.label_parent
     | `Root of string * tag_label_parent
     | `Dot of label_parent * string
-    | `Page_path of page_path
+    | `Page_path of path
+    | `Module_path of path
+    | `Any_path of path
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Class of signature * ClassName.t
@@ -650,6 +653,7 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.module_
     | `Root of string * [ `TModule | `TUnknown ]
     | `Dot of label_parent * string
+    | `Module_path of path
     | `Module of signature * ModuleName.t ]
   (** @canonical Odoc_model.Paths.Reference.Module.t *)
 
@@ -754,14 +758,16 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.page
     | `Root of string * [ `TPage | `TUnknown ]
     | `Dot of label_parent * string
-    | `Page_path of page_path ]
+    | `Page_path of path ]
   (** @canonical Odoc_model.Paths.Reference.Page.t *)
 
   type any =
     [ `Resolved of Resolved_reference.any
     | `Root of string * tag_any
     | `Dot of label_parent * string
-    | `Page_path of page_path
+    | `Page_path of path
+    | `Module_path of path
+    | `Any_path of path
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t

src/model/reference.ml

@@ -81,7 +81,7 @@ let match_extra_odoc_reference_kind (_location as loc) s :
       Some `TValue
   | _ -> None
 
-type reference_kind = [ Paths.Reference.tag_any | `TRelativePath ]
+type reference_kind = [ Paths.Reference.tag_any | `TPathComponent ]
 
 (* Ideally, [tokenize] would call this on every reference kind annotation during
    tokenization, when generating the token list. However, that constrains the
@@ -104,7 +104,7 @@ let match_reference_kind location s : reference_kind =
       match result with
       | Some kind -> kind
       | None -> unknown_reference_qualifier s location |> Error.raise_exception)
-  | `End_in_slash -> `TRelativePath
+  | `End_in_slash -> `TPathComponent
 
 type token = {
   kind : [ `None | `Prefixed of string | `End_in_slash ];
@@ -221,7 +221,7 @@ let parse whole_reference_location s :
     Paths.Reference.t Error.with_errors_and_warnings =
   let open Paths.Reference in
   let open Names in
-  let rec page_path components next_token tokens : PagePath.t =
+  let rec path components next_token tokens : Path.t =
     match (next_token.kind, tokens) with
     | `End_in_slash, [] when next_token.identifier = "" ->
         (* {!/identifier} *)
@@ -237,19 +237,16 @@ let parse whole_reference_location s :
         (* {!identifier'/identifier} *)
         (`TRelativePath, next_token.identifier :: components)
     | `End_in_slash, next_token' :: tokens' ->
-        (* {!page_path/identifier} *)
-        page_path (next_token.identifier :: components) next_token' tokens'
+        (* {!path/identifier} *)
+        path (next_token.identifier :: components) next_token' tokens'
     | (`None | `Prefixed _), _ ->
         (* This is not really expected *)
         expected ~expect_paths:true [] next_token.location
         |> Error.raise_exception
   in
 
-  let dot_or_slash (type parent) (dot : _ -> _ -> parent) identifier next_token
-      tokens : [ `Page_path of PagePath.t | `Dot of parent * string ] =
-    match next_token.kind with
-    | `End_in_slash -> `Page_path (page_path [ identifier ] next_token tokens)
-    | _ -> `Dot (dot next_token tokens, identifier)
+  let ends_in_slash next_token =
+    match next_token.kind with `End_in_slash -> true | _ -> false
   in
 
   let rec signature { kind; identifier; location } tokens : Signature.t =
@@ -259,21 +256,28 @@ let parse whole_reference_location s :
         match kind with
         | (`TUnknown | `TModule | `TModuleType) as kind ->
             `Root (identifier, kind)
-        | `TRelativePath -> `Page_path (`TRelativePath, [ identifier ])
+        | `TPathComponent -> `Module_path (`TRelativePath, [ identifier ])
         | _ ->
             expected ~expect_paths:true [ "module"; "module-type" ] location
             |> Error.raise_exception)
+    | next_token :: tokens when ends_in_slash next_token -> (
+        match kind with
+        | `TUnknown | `TModule ->
+            `Module_path (path [ identifier ] next_token tokens)
+        | _ ->
+            expected ~expect_paths:true [ "module" ] location
+            |> Error.raise_exception)
     | next_token :: tokens -> (
         match kind with
         | `TUnknown ->
-            (dot_or_slash parent identifier next_token tokens :> Signature.t)
+            `Dot ((parent next_token tokens :> LabelParent.t), identifier)
         | `TModule ->
             `Module (signature next_token tokens, ModuleName.make_std identifier)
         | `TModuleType ->
             `ModuleType
               (signature next_token tokens, ModuleTypeName.make_std identifier)
-        | `TRelativePath ->
-            `Page_path (page_path [ identifier ] next_token tokens)
+        | `TPathComponent ->
+            `Module_path (path [ identifier ] next_token tokens)
         | _ ->
             expected ~expect_paths:true [ "module"; "module-type" ] location
             |> Error.raise_exception)
@@ -287,6 +291,13 @@ let parse whole_reference_location s :
         | _ ->
             expected [ "module"; "module-type"; "type" ] location
             |> Error.raise_exception)
+    | next_token :: tokens when ends_in_slash next_token -> (
+        match kind with
+        | `TUnknown | `TModule ->
+            `Module_path (path [ identifier ] next_token tokens)
+        | _ ->
+            expected ~expect_paths:true [ "module" ] location
+            |> Error.raise_exception)
     | next_token :: tokens -> (
         match kind with
         | `TUnknown ->
@@ -326,25 +337,37 @@ let parse whole_reference_location s :
         )
   in
 
-  let rec label_parent { kind; identifier; location } tokens : LabelParent.t =
+  let any_page { identifier; location; _ } kind next_token tokens =
+    let path () = path [ identifier ] next_token tokens in
+    match kind with
+    | `TUnknown -> `Any_path (path ())
+    | `TModule -> `Module_path (path ())
+    | `TPage -> `Page_path (path ())
+    | _ ->
+        expected ~expect_paths:true [ "module"; "page" ] location
+        |> Error.raise_exception
+  in
+
+  let rec label_parent ({ kind; identifier; location } as token) tokens :
+      LabelParent.t =
     let kind = match_reference_kind location kind in
     match tokens with
     | [] -> (
         match kind with
         | ( `TUnknown | `TModule | `TModuleType | `TType | `TClass | `TClassType
           | `TPage ) as kind ->
             `Root (identifier, kind)
-        | `TRelativePath -> `Page_path (`TRelativePath, [ identifier ])
+        | `TPathComponent -> `Page_path (`TRelativePath, [ identifier ])
         | _ ->
             expected ~expect_paths:true
               [ "module"; "module-type"; "type"; "class"; "class-type"; "page" ]
               location
             |> Error.raise_exception)
+    | next_token :: tokens when ends_in_slash next_token ->
+        any_page token kind next_token tokens
     | next_token :: tokens -> (
         match kind with
-        | `TUnknown ->
-            (dot_or_slash label_parent identifier next_token tokens
-              :> LabelParent.t)
+        | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
         | `TModule ->
             `Module (signature next_token tokens, ModuleName.make_std identifier)
         | `TModuleType ->
@@ -357,16 +380,16 @@ let parse whole_reference_location s :
         | `TClassType ->
             `ClassType
               (signature next_token tokens, ClassTypeName.make_std identifier)
-        | `TRelativePath ->
-            `Page_path (page_path [ identifier ] next_token tokens)
+        | `TPathComponent -> `Page_path (path [ identifier ] next_token tokens)
         | _ ->
             expected ~expect_paths:true
               [ "module"; "module-type"; "type"; "class"; "class-type" ]
               location
             |> Error.raise_exception)
   in
 
-  let start_from_last_component { kind; identifier; location } old_kind tokens =
+  let start_from_last_component ({ kind; identifier; location } as token)
+      old_kind tokens =
     let new_kind = match_reference_kind location kind in
     let kind =
       match old_kind with
@@ -394,12 +417,12 @@ let parse whole_reference_location s :
     | [] -> (
         match kind with
         | #Paths.Reference.tag_any as kind -> `Root (identifier, kind)
-        | `TRelativePath -> `Page_path (`TRelativePath, [ identifier ]))
+        | `TPathComponent -> `Page_path (`TRelativePath, [ identifier ]))
+    | next_token :: tokens when ends_in_slash next_token ->
+        any_page token kind next_token tokens
     | next_token :: tokens -> (
         match kind with
-        | `TUnknown ->
-            (dot_or_slash label_parent identifier next_token tokens
-              :> Paths.Reference.t)
+        | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
         | `TModule ->
             `Module (signature next_token tokens, ModuleName.make_std identifier)
         | `TModuleType ->
@@ -460,9 +483,8 @@ let parse whole_reference_location s :
                   |> Error.raise_exception
             in
             (* Prefixed pages are not differentiated. *)
-            `Page_path (page_path [ identifier ] next_token tokens)
-        | `TRelativePath ->
-            `Page_path (page_path [ identifier ] next_token tokens))
+            `Page_path (path [ identifier ] next_token tokens)
+        | `TPathComponent -> `Page_path (path [ identifier ] next_token tokens))
   in
 
   let old_kind, s, location =

src/model_desc/paths_desc.ml

@@ -283,7 +283,7 @@ module General_paths = struct
       | `SubstitutedT c -> C ("`SubstitutedT", (c :> rp), resolved_path)
       | `SubstitutedCT c -> C ("`SubstitutedCT", (c :> rp), resolved_path))
 
-  and page_path_reference : Paths.Reference.PagePath.t t =
+  and path_reference : Paths.Reference.Path.t t =
     let tag_page_path =
       Variant
         (function
@@ -299,7 +299,9 @@ module General_paths = struct
       | `Resolved x -> C ("`Resolved", x, resolved_reference)
       | `Root (x1, x2) -> C ("`Root", (x1, x2), Pair (string, reference_tag))
       | `Dot (x1, x2) -> C ("`Dot", ((x1 :> r), x2), Pair (reference, string))
-      | `Page_path x -> C ("`Page_path", x, page_path_reference)
+      | `Page_path x -> C ("`Page_path", x, path_reference)
+      | `Module_path x -> C ("`Module_path", x, path_reference)
+      | `Any_path x -> C ("`Any_path", x, path_reference)
       | `Module (x1, x2) ->
           C ("`Module", ((x1 :> r), x2), Pair (reference, Names.modulename))
       | `ModuleType (x1, x2) ->

src/xref2/component.ml

@@ -1655,8 +1655,7 @@ module Fmt = struct
           (parent :> t)
           (LabelName.to_string name)
 
-  and model_reference_page_path _c ppf
-      ((tag, components) : Reference.PagePath.t) =
+  and model_reference_path _c ppf ((tag, components) : Reference.Path.t) =
     (match tag with
     | `TRelativePath -> fpf ppf "./"
     | `TAbsolutePath -> fpf ppf "/"
@@ -1671,7 +1670,9 @@ module Fmt = struct
     | `Root (name, _) -> Format.fprintf ppf "unresolvedroot(%s)" name
     | `Dot (parent, str) ->
         Format.fprintf ppf "%a.%s" (model_reference c) (parent :> t) str
-    | `Page_path p -> model_reference_page_path c ppf p
+    | `Page_path p -> model_reference_path c ppf p
+    | `Module_path p -> model_reference_path c ppf p
+    | `Any_path p -> model_reference_path c ppf p
     | `Module (parent, name) ->
         Format.fprintf ppf "%a.%s" (model_reference c)
           (parent :> t)

src/xref2/errors.ml

@@ -10,7 +10,17 @@ module Tools_error = struct
       (* Failed to resolve a module path when applying a fragment item *) ]
 
   type reference_kind =
-    [ `S | `T | `C | `CT | `Page | `Cons | `Field | `Label | `Page_path ]
+    [ `S
+    | `T
+    | `C
+    | `CT
+    | `Page
+    | `Cons
+    | `Field
+    | `Label
+    | `Page_path
+    | `Module_path
+    | `Any_path ]
 
   type expansion_of_module_error =
     [ `OpaqueModule (* The module does not have an expansion *)
@@ -126,7 +136,9 @@ module Tools_error = struct
       | `Cons -> "constructor"
       | `Field -> "field"
       | `Label -> "label"
-      | `Page_path -> "page path"
+      | `Page_path -> "path to a page"
+      | `Module_path -> "path to a module"
+      | `Any_path -> "path"
     in
     Format.pp_print_string fmt k