Skip to content

Commit

Permalink
Adding reference to assets
Browse files Browse the repository at this point in the history
Signed-off-by: Paul-Elliot <[email protected]>
  • Loading branch information
panglesd committed Sep 18, 2023
1 parent c3d154d commit 3dae4aa
Show file tree
Hide file tree
Showing 13 changed files with 152 additions and 53 deletions.
1 change: 1 addition & 0 deletions src/document/comment.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
4 changes: 3 additions & 1 deletion src/model/paths_types.ml
Original file line number Diff line number Diff line change
Expand Up @@ -518,6 +518,7 @@ module rec Reference : sig
| `TInstanceVariable
| `TLabel
| `TPage
| `TAsset
| `TChildPage
| `TChildModule
| `TUnknown ]
Expand Down Expand Up @@ -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 =
Expand Down
23 changes: 23 additions & 0 deletions src/model/reference.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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
Expand Down
7 changes: 6 additions & 1 deletion src/model_desc/paths_desc.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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")

Expand Down Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions src/xref2/component.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions src/xref2/env.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
94 changes: 44 additions & 50 deletions src/xref2/ref_tools.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
2 changes: 1 addition & 1 deletion src/xref2/ref_tools.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Binary file not shown.
5 changes: 5 additions & 0 deletions test/xref2/references_to_assets.t/index.mld
Original file line number Diff line number Diff line change
@@ -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"}
3 changes: 3 additions & 0 deletions test/xref2/references_to_assets.t/other_page.mld
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
{0 Another page with an asset}

Hello darkness my old {!asset-"caml.gif"}.
56 changes: 56 additions & 0 deletions test/xref2/references_to_assets.t/run.t
Original file line number Diff line number Diff line change
@@ -0,0 +1,56 @@
In this file, we test the resolving of asset references.

More precisely we test resolving an an asset reference where the asset lives:
- in the current page (index.mld references ocaml.gif)
- in a parent page (test.mli references ocaml.gif)
- in a sibling page (test.mli references ocaml_not.gif, through page-other_page.ocaml_not.gif)

Compile the module first

$ ocamlc -c -bin-annot test.mli

Then we need to odoc-compile the package mld file, listing its
children. If we omit the asset child, all assets reference resolving fail:

$ odoc compile index.mld --child module-test --child page-other_page
$ odoc compile other_page.mld -I . --parent index
$ odoc compile test.cmti -I . --parent index
$ for i in *.odoc; do odoc link -I . $i; done
File "index.mld", line 5, characters 37-76:
Warning: Failed to resolve reference unresolvedroot(other_page).caml_not.gif Couldn't find asset "caml_not.gif"
File "index.mld", line 3, characters 2-32:
Warning: Failed to resolve reference unresolvedroot(caml.gif) Couldn't find asset "caml.gif"
File "other_page.mld", line 3, characters 22-41:
Warning: Failed to resolve reference unresolvedroot(caml.gif) Couldn't find asset "caml.gif"
File "test.mli", line 4, characters 39-78:
Warning: Failed to resolve reference unresolvedroot(other_page).caml_not.gif Couldn't find asset "caml_not.gif"
File "test.mli", line 2, characters 4-34:
Warning: Failed to resolve reference unresolvedroot(caml.gif) Couldn't find asset "caml.gif"

We should pass the asset as child of a page.

$ odoc compile index.mld --child module-test --child asset-caml.gif --child page-other_page
$ odoc compile test.cmti -I . --parent index
$ odoc compile other_page.mld --child asset-caml_not.gif -I . --parent index

Link and generate the HTML (forgetting the asset!):

$ for i in *.odoc; do odoc link -I . $i; done
$ for i in *.odocl; do odoc html-generate --indent $i -o html; done
File "caml.gif":
Warning: asset is missing.
File "caml_not.gif":
Warning: asset is missing.

Note that the html links are correct (there are dead links due to missing assets)

$ grep caml.gif html/index/index.html
<p>A <a href="caml.gif" title="caml.gif">reference</a> to an asset.</p>
$ grep caml_not.gif html/index/index.html
<a href="other_page/caml_not.gif"><code>caml_not.gif</code></a>
$ grep caml.gif html/index/Test/index.html
<p>A <a href="../caml.gif" title="caml.gif">reference</a> to an asset</p>
$ grep caml_not.gif html/index/Test/index.html
<a href="../other_page/caml_not.gif"><code>caml_not.gif</code></a>
$ grep caml.gif html/index/other_page/index.html
<p>Hello darkness my old <a href="../caml.gif"><code>caml.gif</code></a>.
5 changes: 5 additions & 0 deletions test/xref2/references_to_assets.t/test.mli
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
(**
A {{!asset-"caml.gif"}reference} to an asset
And a reference using a page parent: {!page-other_page.asset-"caml_not.gif"}
*)

0 comments on commit 3dae4aa

Please sign in to comment.