Parse asset references

Signed-off-by: Paul-Elliot <[email protected]>

Author: panglesd

src/document/comment.ml

@@ -77,6 +77,7 @@ module Reference = struct
     | `Root (n, _) -> n
     | `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
     | `Page_path p -> render_path p
+    | `Asset_path p -> render_path p
     | `Module_path p -> render_path p
     | `Any_path p -> render_path p
     | `Module (p, f) ->

src/model/paths.ml

@@ -1092,6 +1092,10 @@ module Reference = struct
     module Page = struct
       type t = Paths_types.Resolved_reference.page
     end
+
+    module Asset = struct
+      type t = Paths_types.Resolved_reference.asset
+    end
   end
 
   type t = Paths_types.Reference.any

src/model/paths.mli

@@ -552,6 +552,10 @@ module rec Reference : sig
       type t = Paths_types.Resolved_reference.page
     end
 
+    module Asset : sig
+      type t = Paths_types.Resolved_reference.asset
+    end
+
     type t = Paths_types.Resolved_reference.any
 
     val identifier : t -> Identifier.t

src/model/paths_types.ml

@@ -576,6 +576,7 @@ module rec Reference : sig
     | `TInstanceVariable
     | `TLabel
     | `TPage
+    | `TAsset
     | `TChildPage
     | `TChildModule
     | `TUnknown ]
@@ -652,6 +653,8 @@ module rec Reference : sig
     | `Type of signature * TypeName.t ]
   (** @canonical Odoc_model.Paths.Reference.LabelParent.t *)
 
+  type asset = [ `Asset_path of hierarchy ]
+
   type module_ =
     [ `Resolved of Resolved_reference.module_
     | `Root of string * [ `TModule | `TUnknown ]
@@ -770,6 +773,7 @@ module rec Reference : sig
     | `Dot of label_parent * string
     | `Page_path of hierarchy
     | `Module_path of hierarchy
+    | `Asset_path of hierarchy
     | `Any_path of hierarchy
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
@@ -930,6 +934,9 @@ and Resolved_reference : sig
   type page = [ `Identifier of Identifier.reference_page ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.Page.t *)
 
+  type asset = [ `Identifier of Identifier.asset_file ]
+  (** @canonical Odoc_model.Paths.Reference.Resolved.Asset.t *)
+
   type any =
     [ `Identifier of Identifier.any
     | `Alias of Resolved_path.module_ * module_

src/model/reference.ml

@@ -90,6 +90,7 @@ let match_extra_odoc_reference_kind (_location as loc) s :
       Some `TLabel
   | "module-type" -> Some `TModuleType
   | "page" -> Some `TPage
+  | "asset" -> Some `TAsset
   | "value" ->
       d loc "value" "val";
       Some `TValue
@@ -352,12 +353,24 @@ let parse whole_reference_location s :
         )
   in
 
+  let label_parent_path { 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 any_path { 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 ())
+    | `TAsset -> `Asset_path (path ())
     | _ ->
         expected ~expect_paths:true [ "module"; "page" ] location
         |> Error.raise_exception
@@ -379,7 +392,7 @@ let parse whole_reference_location s :
               location
             |> Error.raise_exception)
     | next_token :: tokens when ends_in_slash next_token ->
-        any_path token kind next_token tokens
+        label_parent_path token kind next_token tokens
     | next_token :: tokens -> (
         match kind with
         | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
@@ -499,6 +512,21 @@ let parse whole_reference_location s :
             in
             (* Prefixed pages are not differentiated. *)
             `Page_path (path [ identifier ] next_token tokens)
+        | `TAsset ->
+            let () =
+              match next_token.kind with
+              | `End_in_slash -> ()
+              | `None | `Prefixed _ ->
+                  let suggestion =
+                    Printf.sprintf "Reference assets as '<parent_path>/%s'."
+                      identifier
+                  in
+                  not_allowed ~what:"Asset label"
+                    ~in_what:"on the right side of a dot" ~suggestion location
+                  |> Error.raise_exception
+            in
+            (* Prefixed assets are not differentiated. *)
+            `Asset_path (path [ identifier ] next_token tokens)
         | `TPathComponent -> assert false)
   in
 

src/model_desc/paths_desc.ml

@@ -202,6 +202,7 @@ module General_paths = struct
       | `TModule -> C0 "`TModule"
       | `TModuleType -> C0 "`TModuleType"
       | `TPage -> C0 "`TPage"
+      | `TAsset -> C0 "`TAsset"
       | `TType -> C0 "`TType"
       | `TUnknown -> C0 "`TUnknown"
       | `TValue -> C0 "`TValue"
@@ -305,6 +306,7 @@ module General_paths = struct
       | `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, hierarchy_reference)
+      | `Asset_path x -> C ("`Asset_path", x, hierarchy_reference)
       | `Module_path x -> C ("`Module_path", x, hierarchy_reference)
       | `Any_path x -> C ("`Any_path", x, hierarchy_reference)
       | `Module (x1, x2) ->

src/xref2/component.ml

@@ -1679,6 +1679,7 @@ module Fmt = struct
     | `Dot (parent, str) ->
         Format.fprintf ppf "%a.%s" (model_reference c) (parent :> t) str
     | `Page_path p -> model_reference_hierarchy c ppf p
+    | `Asset_path p -> model_reference_hierarchy c ppf p
     | `Module_path p -> model_reference_hierarchy c ppf p
     | `Any_path p -> model_reference_hierarchy c ppf p
     | `Module (parent, name) ->

src/xref2/errors.ml

@@ -20,6 +20,7 @@ module Tools_error = struct
     | `Label
     | `Page_path
     | `Module_path
+    | `Asset_path
     | `Any_path ]
 
   type path_kind = [ `Page | `Unit ]
@@ -144,6 +145,7 @@ module Tools_error = struct
       | `Label -> "label"
       | `Page_path -> "path to a page"
       | `Module_path -> "path to a module"
+      | `Asset_path -> "path to an asset"
       | `Any_path -> "path"
     in
     Format.pp_print_string fmt k

src/xref2/ref_tools.ml

@@ -939,6 +939,7 @@ let resolve_reference : _ -> Reference.t -> _ =
         resolve_label_parent_reference env parent >>= fun p ->
         L.in_label_parent env p name >>= resolved_with_text
     | `Root (name, (`TPage | `TChildPage)) -> Page.in_env env name >>= resolved2
+    | `Root (name, `TAsset) -> Error (`Find_by_name (`Asset_path, name))
     | `Dot (parent, name) -> resolve_reference_dot env parent name
     | `Root (name, `TConstructor) -> CS.in_env env name >>= resolved1
     | `Constructor (parent, name) ->
@@ -969,6 +970,7 @@ let resolve_reference : _ -> Reference.t -> _ =
         resolve_class_signature_reference env parent >>= fun p ->
         MV.in_class_signature env p name >>= resolved1
     | `Page_path p -> Path.page_in_env env p >>= resolved2
+    | `Asset_path (tag, p) -> Error (`Path_error (`Not_found, tag, p))
     | `Module_path p ->
         Path.module_in_env env p
         >>= module_lookup_to_signature_lookup env