WIP: Parsing of page_path

src/model/paths.ml

@@ -1163,4 +1163,8 @@ module Reference = struct
   module Page = struct
     type t = Paths_types.Reference.page
   end
+
+  module PagePath = struct
+    type t = Paths_types.Reference.page_path
+  end
 end

src/model/paths.mli

@@ -633,6 +633,10 @@ module rec Reference : sig
     type t = Paths_types.Reference.page
   end
 
+  module PagePath : sig
+    type t = Paths_types.Reference.page_path
+  end
+
   type t = Paths_types.Reference.any
 
   type tag_any = Paths_types.Reference.tag_any

src/model/paths_types.ml

@@ -553,6 +553,11 @@ module rec Reference : sig
 
   type tag_only_child_module = [ `TChildModule ]
 
+  type tag_page_path =
+    [ `TPath (* {!identifier/} *)
+    | `TRootDir (* {!/identifier} *)
+    | `TCurrentPackage (* {!//identifier} *) ]
+
   type tag_any =
     [ `TModule
     | `TModuleType
@@ -569,6 +574,7 @@ module rec Reference : sig
     | `TInstanceVariable
     | `TLabel
     | `TPage
+    | `TPath
     | `TChildPage
     | `TChildModule
     | `TUnknown ]
@@ -590,7 +596,13 @@ module rec Reference : sig
     | `TType
     | `TPage
     | `TChildPage
-    | `TChildModule ]
+    | `TChildModule
+    | tag_page_path ]
+
+  type page_path =
+    [ `Root of string * tag_page_path
+    | `Slash of page_path * string (* {!page_path/identifier} *) ]
+  (** @canonical Odoc_model.Paths.Reference.PagePath.t *)
 
   type signature =
     [ `Resolved of Resolved_reference.signature
@@ -629,6 +641,7 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.label_parent
     | `Root of string * tag_label_parent
     | `Dot of label_parent * string
+    | `Slash of page_path * string (* {!path/page} *)
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Class of signature * ClassName.t
@@ -742,14 +755,16 @@ module rec Reference : sig
 
   type page =
     [ `Resolved of Resolved_reference.page
-    | `Root of string * [ `TPage | `TUnknown ]
-    | `Dot of label_parent * string ]
+    | `Root of string * [ `TPage | `TUnknown | tag_page_path ]
+    | `Dot of label_parent * string
+    | `Slash of page_path * string (* {!page_path/identifier} *) ]
   (** @canonical Odoc_model.Paths.Reference.Page.t *)
 
   type any =
     [ `Resolved of Resolved_reference.any
-    | `Root of string * tag_any
+    | `Root of string * [ tag_any | tag_page_path ]
     | `Dot of label_parent * string
+    | `Slash of page_path * string (* {!page_path/identifier} *)
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t

src/model/reference.ml

@@ -31,7 +31,7 @@ let deprecated_reference_kind location kind replacement =
 
 (* http://caml.inria.fr/pub/docs/manual-ocaml/ocamldoc.html#sec359. *)
 let match_ocamldoc_reference_kind (_location as loc) s :
-    Paths.Reference.tag_any option =
+    [> Paths.Reference.tag_any ] option =
   let d = deprecated_reference_kind in
   match s with
   | "module" -> Some `TModule
@@ -59,7 +59,7 @@ let match_ocamldoc_reference_kind (_location as loc) s :
   | _ -> None
 
 let match_extra_odoc_reference_kind (_location as loc) s :
-    Paths.Reference.tag_any option =
+    [> Paths.Reference.tag_any ] option =
   let d = deprecated_reference_kind in
   match s with
   | "class-type" -> Some `TClassType
@@ -90,18 +90,19 @@ let match_extra_odoc_reference_kind (_location as loc) s :
 
    A secondary reason to delay parsing, and store strings in the token list, is
    that we need the strings for user-friendly error reporting. *)
-let match_reference_kind location s : Paths.Reference.tag_any =
+let match_reference_kind location s : [> Paths.Reference.tag_any ] =
   match s with
-  | None -> `TUnknown
-  | Some s -> (
+  | `None -> `TUnknown
+  | `Prefix s | `Old_prefix s -> (
       let result =
         match match_ocamldoc_reference_kind location s with
-        | Some kind -> Some kind
+        | Some _ as kind -> kind
         | None -> match_extra_odoc_reference_kind location s
       in
       match result with
       | Some kind -> kind
       | None -> unknown_reference_qualifier s location |> Error.raise_exception)
+  | `End_in_slash -> `TPath
 
 (* The string is scanned right-to-left, because we are interested in right-most
    hyphens. The tokens are also returned in right-to-left order, because the
@@ -112,14 +113,17 @@ let tokenize location s =
     match s.[index] with
     | exception Invalid_argument _ ->
         let identifier, location = identifier_ended started_at index in
-        (None, identifier, location) :: tokens
+        (`None, identifier, location) :: tokens
     | '-' when open_parenthesis_count = 0 ->
         let identifier, location = identifier_ended started_at index in
         scan_kind identifier location index (index - 1) tokens
     | '.' when open_parenthesis_count = 0 ->
         let identifier, location = identifier_ended started_at index in
         scan_identifier index 0 (index - 1)
-          ((None, identifier, location) :: tokens)
+          ((`None, identifier, location) :: tokens)
+    | '/' when open_parenthesis_count = 0 ->
+        let identifier, location = identifier_ended started_at index in
+        scan_path index (index - 1) ((`None, identifier, location) :: tokens)
     | ')' ->
         scan_identifier started_at
           (open_parenthesis_count + 1)
@@ -164,15 +168,31 @@ let tokenize location s =
         let kind, location = kind_ended identifier_location started_at index in
         scan_identifier index 0 (index - 1)
           ((kind, identifier, location) :: tokens)
+    | '/' ->
+        let kind, location = kind_ended identifier_location started_at index in
+        scan_path index (index - 1) ((kind, identifier, location) :: tokens)
     | _ ->
         scan_kind identifier identifier_location started_at (index - 1) tokens
   and kind_ended identifier_location started_at index =
     let offset = index + 1 in
     let length = started_at - offset in
-    let kind = Some (String.sub s offset length) in
+    let kind = `Prefix (String.sub s offset length) in
     let location = Location_.in_string s ~offset ~length location in
     let location = Location_.span [ location; identifier_location ] in
     (kind, location)
+  and scan_path started_at index tokens =
+    (* The parsing rules are different for [/]-separated components. [-"".()] are
+       no longer meaningful. *)
+    match s.[index] with
+    | exception Invalid_argument _ -> path_ended started_at index :: tokens
+    | '/' -> scan_path index (index - 1) (path_ended started_at index :: tokens)
+    | _ -> scan_path started_at (index - 1) tokens
+  and path_ended started_at index =
+    let offset = index + 1 in
+    let length = started_at - offset in
+    let component = String.sub s offset length in
+    let location = Location_.in_string s ~offset ~length location in
+    (`End_in_slash, component, location)
   in
 
   scan_identifier (String.length s) 0 (String.length s - 1) [] |> List.rev
@@ -188,8 +208,8 @@ let expected allowed location =
   in
   expected_err allowed location
 
-let parse whole_reference_location s :
-    Paths.Reference.t Error.with_errors_and_warnings =
+(* Parse references that do not contain a [/]. Raises errors and warnings. *)
+let parse_local_reference whole_reference_location s : Paths.Reference.t =
   let open Paths.Reference in
   let open Names in
   let rec signature (kind, identifier, location) tokens : Signature.t =
@@ -263,6 +283,25 @@ let parse whole_reference_location s :
         )
   in
 
+  let rec page_path identifier next_token tokens : PagePath.t =
+    match (next_token, tokens) with
+    | (`End_in_slash, "", _), [] ->
+        (* {!/} *)
+        `Root (identifier, `TRootDir)
+    | (`End_in_slash, "", _), [ (`End_in_slash, "", _) ] ->
+        (* {!//} *)
+        `Root (identifier, `TCurrentPackage)
+    | (`End_in_slash, identifier', _loc), [] ->
+        (* {!identifier} *)
+        `Slash (`Root (identifier', `TPath), identifier)
+    | (`End_in_slash, identifier', _loc), next_token' :: tokens' ->
+        (* {!path/identifier} *)
+        `Slash (page_path identifier' next_token' tokens', identifier)
+    | ((`None | `Prefix _), _, loc), _ ->
+        (* This is not really expected *)
+        expected [ "path separated components" ] loc |> Error.raise_exception
+  in
+
   let rec label_parent (kind, identifier, location) tokens : LabelParent.t =
     let kind = match_reference_kind location kind in
     match tokens with
@@ -305,14 +344,16 @@ let parse whole_reference_location s :
       | None -> new_kind
       | Some (old_kind_string, old_kind_location) -> (
           let old_kind =
-            match_reference_kind old_kind_location (Some old_kind_string)
+            match_reference_kind old_kind_location (`Old_prefix old_kind_string)
           in
           match new_kind with
           | `TUnknown -> old_kind
           | _ ->
               (if old_kind <> new_kind then
                  let new_kind_string =
-                   match kind with Some s -> s | None -> ""
+                   match kind with
+                   | `None | `End_in_slash -> ""
+                   | `Prefix s -> s
                  in
                  reference_kinds_do_not_match old_kind_string new_kind_string
                    whole_reference_location
@@ -378,7 +419,9 @@ let parse whole_reference_location s :
             not_allowed ~what:"Page label"
               ~in_what:"the last component of a reference path" ~suggestion
               location
-            |> Error.raise_exception)
+            |> Error.raise_exception
+        | `TPath ->
+            (page_path identifier next_token tokens :> Paths.Reference.t))
   in
 
   let old_kind, s, location =
@@ -405,14 +448,19 @@ let parse whole_reference_location s :
         (Some (old_kind, old_kind_location), s, location)
     | exception Not_found -> (None, s, whole_reference_location)
   in
+  match tokenize location s with
+  | last_token :: tokens -> start_from_last_component last_token old_kind tokens
+  | [] ->
+      should_not_be_empty ~what:"Reference target" whole_reference_location
+      |> Error.raise_exception
+
+(* Parse references containing [/]. Raises errors and warnings. *)
+(* let parse_global_reference : Paths.Reference.t = *)
 
+let parse loc s : Paths.Reference.t Error.with_errors_and_warnings =
   Error.catch_errors_and_warnings (fun () ->
-      match tokenize location s with
-      | last_token :: tokens ->
-          start_from_last_component last_token old_kind tokens
-      | [] ->
-          should_not_be_empty ~what:"Reference target" whole_reference_location
-          |> Error.raise_exception)
+      (* if String.contains s '/' then parse_global_reference loc s else *)
+      parse_local_reference loc s)
 
 type path = [ `Root of string | `Dot of Paths.Path.Module.t * string ]