Merge pull request #1171 from panglesd/odoc3-asset-references

Julow · web-flow · commit 2ca8c072f016 · 2024-07-31T15:01:29.000+02:00
Parse and resolve asset references
diff --git a/CHANGES.md b/CHANGES.md
@@ -25,6 +25,7 @@
   number of occurrences of each entry of the index in the json output
   (@panglesd, #1076).
 - Added a `compile-asset` command (@EmileTrotignon, @panglesd, #1170)
+- Allow referencing assets (@panglesd, #1171)
 
 ### Changed
 
diff --git a/src/document/comment.ml b/src/document/comment.ml
@@ -76,6 +76,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) ->
diff --git a/src/document/url.ml b/src/document/url.ml
@@ -190,6 +190,7 @@ module Path = struct
     | { iv = `AssetFile (parent, name); _ } ->
         let parent = from_identifier (parent :> any) in
         let kind = `File in
+        let name = AssetName.to_string name in
         mk ~parent kind name
 
   let from_identifier p =
diff --git a/src/model/names.ml b/src/model/names.ml
@@ -159,3 +159,4 @@ module LabelName = SimpleName
 module PageName = SimpleName
 module DefName = SimpleName
 module LocalName = SimpleName
+module AssetName = SimpleName
diff --git a/src/model/names.mli b/src/model/names.mli
@@ -100,3 +100,5 @@ module PageName : SimpleName
 module DefName : SimpleName
 
 module LocalName : SimpleName
+
+module AssetName : SimpleName
diff --git a/src/model/paths.ml b/src/model/paths.ml
@@ -61,7 +61,7 @@ module Identifier = struct
     | `SourceLocationMod x -> name_aux (x :> t)
     | `SourceLocationInternal (x, anchor) ->
         name_aux (x :> t) ^ "#" ^ LocalName.to_string anchor
-    | `AssetFile (_, name) -> name
+    | `AssetFile (_, name) -> AssetName.to_string name
 
   let rec is_hidden : t -> bool =
    fun x ->
@@ -143,7 +143,8 @@ module Identifier = struct
         LocalName.to_string name :: full_name_aux (parent :> t)
     | `SourceLocationMod name -> full_name_aux (name :> t)
     | `SourcePage (parent, name) -> name :: full_name_aux (parent :> t)
-    | `AssetFile (parent, name) -> name :: full_name_aux (parent :> t)
+    | `AssetFile (parent, name) ->
+        AssetName.to_string name :: full_name_aux (parent :> t)
 
   let fullname : [< t_pv ] id -> string list =
    fun n -> List.rev @@ full_name_aux (n :> t)
@@ -497,8 +498,8 @@ module Identifier = struct
         [> `LeafPage of ContainerPage.t option * PageName.t ] id =
       mk_parent_opt PageName.to_string "lp" (fun (p, n) -> `LeafPage (p, n))
 
-    let asset_file : Page.t * string -> AssetFile.t =
-      mk_parent (fun k -> k) "asset" (fun (p, n) -> `AssetFile (p, n))
+    let asset_file : Page.t * AssetName.t -> AssetFile.t =
+      mk_parent AssetName.to_string "asset" (fun (p, n) -> `AssetFile (p, n))
 
     let source_page (container_page, path) =
       let rec source_dir dir =
@@ -1090,6 +1091,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
diff --git a/src/model/paths.mli b/src/model/paths.mli
@@ -253,7 +253,7 @@ module Identifier : sig
 
     val source_page : ContainerPage.t * string list -> SourcePage.t
 
-    val asset_file : Page.t * string -> AssetFile.t
+    val asset_file : Page.t * AssetName.t -> AssetFile.t
 
     val root :
       ContainerPage.t option * ModuleName.t ->
@@ -551,6 +551,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
diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml
@@ -32,7 +32,7 @@ module Identifier = struct
   type source_page = source_page_pv id
   (** @canonical Odoc_model.Paths.Identifier.SourcePage.t *)
 
-  type asset_file_pv = [ `AssetFile of page * string ]
+  type asset_file_pv = [ `AssetFile of page * AssetName.t ]
   (** The second argument is the filename.
 
     @canonical Odoc_model.Paths.Identifier.AssetFile.t_pv *)
@@ -575,6 +575,7 @@ module rec Reference : sig
     | `TInstanceVariable
     | `TLabel
     | `TPage
+    | `TAsset
     | `TChildPage
     | `TChildModule
     | `TUnknown ]
@@ -651,6 +652,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 ]
@@ -769,6 +772,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
@@ -929,6 +933,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_
diff --git a/src/model/reference.ml b/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
 
diff --git a/src/model/root.ml b/src/model/root.ml
@@ -94,7 +94,7 @@ let to_string t =
     | `AssetFile (parent, name) ->
         Format.fprintf fmt "%a::%s" pp
           (parent :> Paths.Identifier.OdocId.t)
-          name
+          (Names.AssetName.to_string name)
   in
 
   Format.asprintf "%a" pp t.id
diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml
@@ -36,6 +36,8 @@ module Names = struct
 
   let pagename = To_string PageName.to_string
 
+  let assetname = To_string AssetName.to_string
+
   let parametername = To_string ModuleName.to_string
 
   let defname = To_string DefName.to_string
@@ -77,7 +79,10 @@ module General_paths = struct
                 ((parent :> id_t option), name),
                 Pair (Option identifier, Names.pagename) )
         | `AssetFile (parent, name) ->
-            C ("`AssetFile", ((parent :> id_t), name), Pair (identifier, string))
+            C
+              ( "`AssetFile",
+                ((parent :> id_t), name),
+                Pair (identifier, Names.assetname) )
         | `Root (parent, name) ->
             C
               ( "`Root",
@@ -197,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"
@@ -300,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) ->
diff --git a/src/odoc/asset.ml b/src/odoc/asset.ml
@@ -2,7 +2,8 @@ let compile ~parent_id ~name ~output_dir =
   let open Odoc_model in
   let parent_id = Compile.mk_id parent_id in
   let id =
-    Paths.Identifier.Mk.asset_file ((parent_id :> Paths.Identifier.Page.t), name)
+    Paths.Identifier.Mk.asset_file
+      ((parent_id :> Paths.Identifier.Page.t), Names.AssetName.make_std name)
   in
   let directory =
     Compile.path_of_id output_dir parent_id
diff --git a/src/odoc/html_page.ml b/src/odoc/html_page.ml
@@ -58,7 +58,10 @@ let asset_documents parent_id children asset_paths =
           Error.raise_warning (Error.filename_only "asset is missing." name);
           None
       | Some path ->
-          let asset_id = Paths.Identifier.Mk.asset_file (parent_id, name) in
+          let asset_id =
+            Paths.Identifier.Mk.asset_file
+              (parent_id, Names.AssetName.make_std name)
+          in
           let url = Odoc_document.Url.Path.from_identifier asset_id in
           Some (Odoc_document.Types.Document.Asset { url; src = path }))
     paired_or_missing
diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml
@@ -447,6 +447,13 @@ let lookup_path ~possible_unit_names ~named_roots ~hierarchy (tag, path) :
       |> List.find_map find_in_hierarchy
       |> option_to_result
 
+let lookup_asset_by_path ~pages ~hierarchy path =
+  let possible_unit_names name = [ "asset-" ^ name ^ ".odoc" ] in
+  match lookup_path ~possible_unit_names ~named_roots:pages ~hierarchy path with
+  | Ok (Odoc_file.Asset_content asset) -> Ok asset
+  | Ok _ -> Error `Not_found (* TODO: Report is not an asset. *)
+  | Error _ as e -> e
+
 let lookup_page_by_path ~pages ~hierarchy path =
   let possible_unit_names name = [ "page-" ^ name ^ ".odoc" ] in
   match lookup_path ~possible_unit_names ~named_roots:pages ~hierarchy path with
@@ -472,6 +479,10 @@ let lookup_page ap ~pages ~hierarchy = function
   | `Path p -> lookup_page_by_path ~pages ~hierarchy p
   | `Name n -> lookup_page_by_name ap n
 
+let lookup_asset ~pages ~hierarchy = function
+  | `Path p -> lookup_asset_by_path ~pages ~hierarchy p
+  | `Name _ -> failwith "TODO"
+
 type t = {
   important_digests : bool;
   ap : Accessible_paths.t;
@@ -566,8 +577,11 @@ let build_compile_env_for_unit
   let lookup_unit =
     lookup_unit ~important_digests ~imports_map ap ~libs:None ~hierarchy:None
   and lookup_page _ = Error `Not_found
+  and lookup_asset _ = Error `Not_found
   and lookup_impl = lookup_impl ap in
-  let resolver = { Env.open_units; lookup_unit; lookup_page; lookup_impl } in
+  let resolver =
+    { Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_asset }
+  in
   Env.env_of_unit m ~linking:false resolver
 
 (** [important_digests] and [imports_map] only apply to modules. *)
@@ -589,8 +603,9 @@ let build ?(imports_map = StringMap.empty) ?hierarchy_roots
   let lookup_unit =
     lookup_unit ~important_digests ~imports_map ap ~libs ~hierarchy
   and lookup_page = lookup_page ap ~pages ~hierarchy
+  and lookup_asset = lookup_asset ~pages ~hierarchy
   and lookup_impl = lookup_impl ap in
-  { Env.open_units; lookup_unit; lookup_page; lookup_impl }
+  { Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_asset }
 
 let build_compile_env_for_impl t i =
   let imports_map =
diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml
@@ -39,6 +39,7 @@ let rec of_id x =
   match x.iv with
   | `Root (_, name) -> [ ret "Root" (ModuleName.to_string name) ]
   | `Page (_, name) -> [ ret "Page" (PageName.to_string name) ]
+  | `AssetFile (_, name) -> [ ret "Asset" (AssetName.to_string name) ]
   | `LeafPage (_, name) -> [ ret "Page" (PageName.to_string name) ]
   | `Module (parent, name) ->
       ret "Module" (ModuleName.to_string name) :: of_id (parent :> t)
@@ -76,7 +77,7 @@ let rec of_id x =
   | `Label (parent, name) ->
       ret "Label" (LabelName.to_string name) :: of_id (parent :> t)
   | `SourceDir _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _
-  | `SourceLocationInternal _ | `AssetFile _ ->
+  | `SourceLocationInternal _ ->
       [ `Null ]
 (* TODO *)
 
diff --git a/src/xref2/component.ml b/src/xref2/component.ml
@@ -744,7 +744,9 @@ module Fmt = struct
     | `SourceLocationMod p ->
         Format.fprintf ppf "%a#" (model_identifier c) (p :> id)
     | `AssetFile (p, name) ->
-        Format.fprintf ppf "%a/%s" (model_identifier c) (p :> id) name
+        Format.fprintf ppf "%a/%s" (model_identifier c)
+          (p :> id)
+          (AssetName.to_string name)
 
   let rec signature : config -> Format.formatter -> Signature.t -> unit =
    fun c ppf sg ->
@@ -1676,6 +1678,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) ->
diff --git a/src/xref2/env.ml b/src/xref2/env.ml
@@ -14,6 +14,7 @@ type resolver = {
   open_units : string list;
   lookup_unit : path_query -> (lookup_unit_result, lookup_error) result;
   lookup_page : path_query -> (Lang.Page.t, lookup_error) result;
+  lookup_asset : path_query -> (Lang.Asset.t, lookup_error) result;
   lookup_impl : string -> Lang.Implementation.t option;
 }
 
@@ -431,6 +432,11 @@ let lookup_page query env =
   | None -> Error `Not_found
   | Some r -> r.lookup_page query
 
+let lookup_asset query env =
+  match env.resolver with
+  | None -> Error `Not_found
+  | Some r -> r.lookup_asset query
+
 let lookup_unit query env =
   match env.resolver with
   | None -> Error `Not_found
@@ -442,6 +448,9 @@ let lookup_impl name env =
 let lookup_page_by_name n env = lookup_page (`Name n) env
 let lookup_page_by_path p env = lookup_page (`Path p) env
 
+let lookup_asset_by_name p env = lookup_asset (`Name p) env
+let lookup_asset_by_path p env = lookup_asset (`Path p) env
+
 let lookup_unit_by_path p env =
   match lookup_unit (`Path p) env with
   | Ok (Found u) ->
diff --git a/src/xref2/env.mli b/src/xref2/env.mli
diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml
diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml
diff --git a/test/xref2/path_references.t/doc/foo.mld b/test/xref2/path_references.t/doc/foo.mld
diff --git a/test/xref2/path_references.t/run.t b/test/xref2/path_references.t/run.t
