Adding reference to assets

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

Author: panglesd

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/paths_types.ml

@@ -518,6 +518,7 @@ module rec Reference : sig
     | `TInstanceVariable
     | `TLabel
     | `TPage
+    | `TAsset
     | `TChildPage
     | `TChildModule
     | `TUnknown ]
@@ -706,7 +707,8 @@ 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 =

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

@@ -1514,6 +1514,10 @@ 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

src/xref2/env.ml

@@ -816,6 +816,7 @@ 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 =

src/xref2/ref_tools.ml

@@ -729,10 +729,48 @@ let resolve_reference_dot env parent name =
   | (`C _ | `CT _) as p -> resolve_reference_dot_class env p name
   | `P _ as page -> resolve_reference_dot_page env page name
 
+let resolve_page_reference env (r : Reference.Page.t) =
+  match r with
+  | `Resolved _ -> failwith "unimplemented"
+  | `Dot (_, name) | `Root (name, _) -> Page.in_env env name
+
+let resolve_asset_reference env (m : Reference.Asset.t) =
+  let has_asset children asset =
+    List.exists
+      (function
+        | Odoc_model.Lang.Page.Asset_child a -> String.equal a asset
+        | _ -> false)
+      children
+  in
+  let rec find_in_page (page : Identifier.Page.t option) asset_name :
+      (Reference.Resolved.Asset.t, _) result =
+    match page with
+    | Some page -> (
+        match page.Identifier.iv with
+        | `Page (parent, page)
+        | `LeafPage (parent, page) -> (
+            match Env.lookup_page (PageName.to_string page) env with
+            | Some { children; name; _ } when has_asset children asset_name ->
+                Ok (`Identifier (Identifier.Mk.asset_file (name, asset_name)))
+            | _ ->
+                let parent = (parent :> Identifier.Page.t option) in
+                find_in_page parent asset_name))
+    | None -> Error (`Lookup_by_name (`Asset, asset_name))
+  in
+  match m with
+  | `Resolved r -> Ok r
+  | `Root (name, _) -> (
+      match Env.parent_page env with
+      | None -> Error (`Lookup_by_name (`Asset, name))
+      | Some parent_page -> find_in_page (Some parent_page) name)
+  | `Asset (parent_page, name) ->
+      resolve_page_reference env parent_page >>= fun (_, { name = p; _ }) ->
+      find_in_page (Some p) (AssetName.to_string name)
+
 (** Warnings may be generated with [Error.implicit_warning] *)
 let resolve_reference =
   let resolved = resolved3 in
-  fun env r ->
+  fun env (r : t) ->
     match r with
     | `Root (name, `TUnknown) -> (
         let identifier id = Ok (`Identifier (id :> Identifier.t)) in
@@ -803,63 +841,19 @@ let resolve_reference =
         resolve_class_signature_reference env parent >>= fun p ->
         MM.in_class_signature env p name >>= resolved1
     | `Root (name, `TInstanceVariable) -> MV.in_env env name >>= resolved1
+    | (`Asset _ | `Root (_, `TAsset)) as t ->
+        resolve_asset_reference env t >>= fun res -> Ok (res :> Resolved.t)
     | `InstanceVariable (parent, name) ->
         resolve_class_signature_reference env parent >>= fun p ->
         MV.in_class_signature env p name >>= resolved1
 
 let resolve_module_reference env m =
   Odoc_model.Error.catch_warnings (fun () -> resolve_module_reference env m)
 
-let resolve_reference env m =
+let resolve_reference :
+    Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings =
+ fun env m ->
   Odoc_model.Error.catch_warnings (fun () -> resolve_reference env m)
 
-let resolve_page_reference env (r : Reference.Page.t) =
-  match r with
-  | `Resolved _ -> failwith "unimplemented"
-  | `Dot (_, name) | `Root (name, _) -> Page.in_env env name
-
-let resolve_asset_reference env (m : Reference.Asset.t) =
-  let has_asset children asset =
-    List.exists
-      (function
-        | Odoc_model.Lang.Page.Asset_child a -> String.equal a asset
-        | _ -> false)
-      children
-  in
-  let rec find_in_page (page : Identifier.Page.t option) asset_name :
-      (Reference.Asset.t, _) result =
-    match page with
-    | Some page -> (
-        match page.Identifier.iv with
-        | `Page (parent, page) -> (
-            match Env.lookup_page (PageName.to_string page) env with
-            | Some { children; name; _ } when has_asset children asset_name ->
-                Ok
-                  (`Resolved
-                    (`Identifier (Identifier.Mk.asset_file (name, asset_name))))
-            | _ ->
-                let parent = (parent :> Identifier.Page.t option) in
-                find_in_page parent asset_name)
-        | `LeafPage (parent, page) -> (
-            match Env.lookup_page (PageName.to_string page) env with
-            | Some { children; name; _ } when has_asset children asset_name ->
-                Ok
-                  (`Resolved
-                    (`Identifier (Identifier.Mk.asset_file (name, asset_name))))
-            | _ ->
-                let parent = (parent :> Identifier.Page.t option) in
-                find_in_page parent asset_name))
-    | None -> Error (`Lookup_by_name (`Asset, asset_name))
-  in
-  match m with
-  | `Resolved _ as r -> Ok r
-  | `Root (name, _) -> (
-      match Env.parent_page env with
-      | None -> Error (`Lookup_by_name (`Asset, name))
-      | Some parent_page -> find_in_page (Some parent_page) name)
-  | `Asset (parent_page, name) ->
-      resolve_page_reference env parent_page >>= fun (_, { name = p; _ }) ->
-      find_in_page (Some p) (AssetName.to_string name)
-
 let resolve_asset_reference env m =
   Odoc_model.Error.catch_warnings (fun () -> resolve_asset_reference env m)

src/xref2/ref_tools.mli

@@ -15,4 +15,4 @@ val resolve_reference :
   Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings
 
 val resolve_asset_reference :
-  Env.t -> Asset.t -> Asset.t ref_result Odoc_model.Error.with_warnings
+  Env.t -> Asset.t -> Resolved.Asset.t ref_result Odoc_model.Error.with_warnings

test/xref2/references_to_assets.t/caml.gif_hidden

@@ -0,0 +1,5 @@
+{0 Package page}
+
+A {{!asset-"caml.gif"}reference} to an asset.
+
+And a reference using a page parent: {!page-other_page.asset-"caml_not.gif"}