Introduce resolving of asset referencing

Reference can now be toward assets.
When resolving them, look up the assets of the current page, and if
not found, recurse in the parent page.

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

src/document/comment.ml

@@ -84,6 +84,7 @@ module Reference = struct
     | `InstanceVariable (p, f) ->
         render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f
     | `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f
+    | `Asset (p, f) -> render_unresolved (p :> t) ^ "." ^ AssetName.to_string f
 
   (* This is the entry point. *)
   let to_ir : ?text:Inline.t -> Reference.t -> Inline.t =

src/model/names.ml

@@ -143,3 +143,4 @@ module LabelName = SimpleName
 module PageName = SimpleName
 module DefName = SimpleName
 module LocalName = SimpleName
+module AssetName = SimpleName

src/model/names.mli

@@ -99,3 +99,5 @@ module PageName : SimpleName
 module DefName : SimpleName
 
 module LocalName : SimpleName
+
+module AssetName : SimpleName

src/model/paths.ml

@@ -935,6 +935,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
@@ -1016,4 +1020,8 @@ module Reference = struct
   module Page = struct
     type t = Paths_types.Reference.page
   end
+
+  module Asset = struct
+    type t = Paths_types.Reference.asset
+  end
 end

src/model/paths.mli

@@ -507,6 +507,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
@@ -588,6 +592,10 @@ module rec Reference : sig
     type t = Paths_types.Reference.page
   end
 
+  module Asset : sig
+    type t = Paths_types.Reference.asset
+  end
+
   type t = Paths_types.Reference.any
 
   type tag_any = Paths_types.Reference.tag_any

src/model/paths_types.ml

@@ -290,6 +290,8 @@ module Identifier = struct
   type reference_label = label
 
   type reference_page = page
+
+  type reference_asset = asset_file
 end
 
 module rec Path : sig
@@ -516,6 +518,7 @@ module rec Reference : sig
     | `TInstanceVariable
     | `TLabel
     | `TPage
+    | `TAsset
     | `TChildPage
     | `TChildModule
     | `TUnknown ]
@@ -704,8 +707,16 @@ module rec Reference : sig
     | `ClassType of signature * ClassTypeName.t
     | `Method of class_signature * MethodName.t
     | `InstanceVariable of class_signature * InstanceVariableName.t
-    | `Label of label_parent * LabelName.t ]
+    | `Label of label_parent * LabelName.t
+    | `Asset of page * AssetName.t ]
   (** @canonical Odoc_model.Paths.Reference.t *)
+
+  type asset =
+    [ `Resolved of Resolved_reference.asset
+    | `Root of string * [ `TAsset ]
+    | `Dot of label_parent * string
+    | `Asset of page * AssetName.t ]
+  (** @canonical Odoc_model.Paths.Reference.Asset.t *)
 end =
   Reference
 
@@ -859,5 +870,8 @@ and Resolved_reference : sig
     | `InstanceVariable of class_signature * InstanceVariableName.t
     | `Label of label_parent * LabelName.t ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.t *)
+
+  type asset = [ `Identifier of Identifier.reference_asset ]
+  (** @canonical Odoc_model.Paths.Reference.Resolved.Asset.t *)
 end =
   Resolved_reference

src/model/reference.ml

@@ -75,6 +75,7 @@ let match_extra_odoc_reference_kind (_location as loc) s :
       Some `TLabel
   | Some "module-type" -> Some `TModuleType
   | Some "page" -> Some `TPage
+  | Some "asset" -> Some `TAsset
   | Some "value" ->
       d loc "value" "val";
       Some `TValue
@@ -323,6 +324,26 @@ let parse whole_reference_location s :
             |> Error.raise_exception)
   in
 
+  let page (kind, identifier, location) tokens : Page.t =
+    let kind = match_reference_kind location kind in
+    match tokens with
+    | [] -> (
+        match kind with
+        | (`TUnknown | `TPage) as kind -> `Root (identifier, kind)
+        | _ -> expected [ "page" ] location |> Error.raise_exception)
+    | next_token :: tokens -> (
+        match kind with
+        | `TUnknown -> `Dot (label_parent next_token tokens, identifier)
+        | _ ->
+            let suggestion =
+              Printf.sprintf "'page-%s' should be first." identifier
+            in
+            not_allowed ~what:"Page label"
+              ~in_what:"the last component of a reference path" ~suggestion
+              location
+            |> Error.raise_exception)
+  in
+
   let start_from_last_component (kind, identifier, location) old_kind tokens =
     let new_kind = match_reference_kind location kind in
     let kind =
@@ -385,6 +406,8 @@ let parse whole_reference_location s :
         | `TLabel ->
             `Label
               (label_parent next_token tokens, LabelName.make_std identifier)
+        | `TAsset ->
+            `Asset (page next_token tokens, AssetName.make_std identifier)
         | `TChildPage | `TChildModule ->
             let suggestion =
               Printf.sprintf "'child-%s' should be first." identifier

src/model_desc/paths_desc.ml

@@ -34,6 +34,8 @@ module Names = struct
 
   let labelname = To_string LabelName.to_string
 
+  let assetname = To_string AssetName.to_string
+
   let pagename = To_string PageName.to_string
 
   let parametername = To_string ModuleName.to_string
@@ -194,6 +196,7 @@ module General_paths = struct
       | `TType -> C0 "`TType"
       | `TUnknown -> C0 "`TUnknown"
       | `TValue -> C0 "`TValue"
+      | `TAsset -> C0 "`TValue"
       | `TChildPage -> C0 "`TChildPage"
       | `TChildModule -> C0 "`TChildModule")
 
@@ -316,7 +319,9 @@ module General_paths = struct
               ((x1 :> r), x2),
               Pair (reference, Names.instancevariablename) )
       | `Label (x1, x2) ->
-          C ("`Label", ((x1 :> r), x2), Pair (reference, Names.labelname)))
+          C ("`Label", ((x1 :> r), x2), Pair (reference, Names.labelname))
+      | `Asset (x1, x2) ->
+          C ("`Asset", ((x1 :> r), x2), Pair (reference, Names.assetname)))
 
   and resolved_reference : rr t =
     Variant

src/xref2/component.ml

@@ -1450,6 +1450,11 @@ module Fmt = struct
           (parent :> t)
           (LabelName.to_string name)
 
+  and model_resolved_asset_reference ppf
+      (`Identifier id : Odoc_model.Paths.Reference.Resolved.Asset.t) =
+    Format.fprintf ppf "%a" model_identifier
+      (id :> Odoc_model.Paths.Identifier.t)
+
   and model_reference ppf (r : Odoc_model.Paths.Reference.t) =
     let open Odoc_model.Paths.Reference in
     match r with
@@ -1509,6 +1514,23 @@ module Fmt = struct
         Format.fprintf ppf "%a.%s" model_reference
           (parent :> t)
           (LabelName.to_string name)
+    | `Asset (parent, name) ->
+        Format.fprintf ppf "%a.%s" model_reference
+          (parent :> t)
+          (AssetName.to_string name)
+
+  and model_asset_reference ppf (r : Odoc_model.Paths.Reference.Asset.t) =
+    let open Odoc_model.Paths.Reference in
+    match r with
+    | `Resolved r' ->
+        Format.fprintf ppf "r(%a)" model_resolved_asset_reference r'
+    | `Root (name, _) -> Format.fprintf ppf "unresolvedroot(%s)" name
+    | `Dot (parent, str) ->
+        Format.fprintf ppf "%a.%s" model_reference (parent :> t) str
+    | `Asset (parent, name) ->
+        Format.fprintf ppf "%a.%s" model_reference
+          (parent :> t)
+          (AssetName.to_string name)
 end
 
 module LocalIdents = struct

src/xref2/component.mli

@@ -623,7 +623,13 @@ module Fmt : sig
   val model_resolved_reference :
     Format.formatter -> Odoc_model.Paths.Reference.Resolved.t -> unit
 
+  val model_resolved_asset_reference :
+    Format.formatter -> Odoc_model.Paths.Reference.Resolved.Asset.t -> unit
+
   val model_reference : Format.formatter -> Odoc_model.Paths.Reference.t -> unit
+
+  val model_asset_reference :
+    Format.formatter -> Odoc_model.Paths.Reference.Asset.t -> unit
 end
 
 module Of_Lang : sig

src/xref2/env.ml

@@ -163,6 +163,7 @@ type t = {
   resolver : resolver option;
   recorder : recorder option;
   fragmentroot : (int * Component.Signature.t) option;
+  parent_page : Identifier.Page.t option;  (** parent page *)
 }
 
 let is_linking env = env.linking
@@ -199,6 +200,7 @@ let empty =
     recorder = None;
     ambiguous_labels = Identifier.Maps.Label.empty;
     fragmentroot = None;
+    parent_page = None;
   }
 
 let add_fragment_root sg env =
@@ -802,12 +804,19 @@ let env_of_unit t ~linking resolver =
     let env = { empty with linking } in
     env |> add_module (t.id :> Identifier.Path.Module.t) dm m.doc
   in
+  let parent_page :> Identifier.Page.t option =
+    match t.id.iv with
+    | `Root (None, _) -> None
+    | `Root (Some parent, _) -> Some parent
+  in
+  let initial_env = { initial_env with parent_page } in
   set_resolver initial_env resolver |> open_units resolver
 
 let open_page page env = add_docs page.Lang.Page.content env
 
 let env_of_page page resolver =
   let initial_env = open_page page empty in
+  let initial_env = { initial_env with parent_page = Some page.name } in
   set_resolver initial_env resolver |> open_units resolver
 
 let env_for_reference resolver =
@@ -870,3 +879,5 @@ let verify_lookups env lookups =
   | true, Some r -> r.lookups <- LookupTypeSet.union r.lookups lookups
   | _ -> ());
   result
+
+let parent_page env = env.parent_page

src/xref2/env.mli

@@ -178,3 +178,5 @@ val len : int ref
 val n : int ref
 
 val verify_lookups : t -> LookupTypeSet.t -> bool
+
+val parent_page : t -> Identifier.Page.t option

src/xref2/errors.ml

@@ -9,7 +9,8 @@ module Tools_error = struct
       [ `Module of Cpath.module_ ]
       (* Failed to resolve a module path when applying a fragment item *) ]
 
-  type reference_kind = [ `S | `T | `C | `CT | `Page | `Cons | `Field | `Label ]
+  type reference_kind =
+    [ `S | `T | `C | `CT | `Page | `Cons | `Field | `Label | `Asset | `Asset_or_label ]
 
   type expansion_of_module_error =
     [ `OpaqueModule (* The module does not have an expansion *)
@@ -115,6 +116,8 @@ module Tools_error = struct
       | `Cons -> "constructor"
       | `Field -> "field"
       | `Label -> "label"
+      | `Asset -> "asset"
+      | `Asset_or_label -> "asset or label"
     in
     Format.pp_print_string fmt k
 
@@ -291,7 +294,8 @@ type what =
   | `Module_type_u_expr of Component.ModuleType.U.expr
   | `Child_module of string
   | `Child_page of string
-  | `Reference of Reference.t ]
+  | `Reference of Reference.t
+  | `Asset_reference of Reference.Asset.t ]
 
 let report ~(what : what) ?tools_error action =
   let action =
@@ -340,6 +344,7 @@ let report ~(what : what) ?tools_error action =
     | `Child_module rf -> r "child module" Astring.String.pp rf
     | `Child_page rf -> r "child page" Astring.String.pp rf
     | `Reference ref -> r "reference" model_reference ref
+    | `Asset_reference ref -> r "asset reference" model_asset_reference ref
   in
   match kind_of_error ~what tools_error with
   | Some (`Root name) -> Lookup_failures.report_root ~name