diff --git a/CHANGES.md b/CHANGES.md index 9ab5191c07..5b127e8266 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,7 @@ - Improve jump to implementation in rendered source code, and add a `count-occurrences` flag and command to count occurrences of every identifiers (@panglesd, #976) +- Add ability to reference assets (@panglesd, #1002) # 2.4.0 diff --git a/doc/ocamldoc_differences.mld b/doc/ocamldoc_differences.mld index 507ea754f6..f2f85f927e 100644 --- a/doc/ocamldoc_differences.mld +++ b/doc/ocamldoc_differences.mld @@ -33,6 +33,7 @@ The following describes the changes between what [odoc] understands and what’s - [odoc] has a better mechanism for disambiguating references in comments. See 'reference syntax' later in this document. - Built-in support for standalone [.mld] files. These are documents using the OCamldoc markup, but they’re rendered as distinct pages. - Structured output: [odoc] can produce output in a structured directory tree rather a set of files. +- [odoc] support the inclusion of assets in the structured directory tree. - A few extra tags are supported: + [@returns] is a synonym for [@return] + [@raises] is a synonym for [@raise] @@ -56,6 +57,7 @@ Additionally we support extra annotations: - [instance-variable] refers to instance variables - [label] refers to labels introduced in anchors - [page] refers to [.mld] pages as outlined above +- [asset] refers assets as outlined above - [value] is recognised as [val] {3 Referencing items containing hyphens or dots} diff --git a/doc/odoc_for_authors.mld b/doc/odoc_for_authors.mld index 11d32bbbd2..dcfd0e91ad 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -393,13 +393,14 @@ The prefixes supported are: - [instance-variable] - [section] (and the equivalent deprecated prefix [label]) - for referring to headings - [page] - for referring to [.mld] pages +- [asset] - for referring to assets In some cases the element being referenced might have a hyphen, a dot or a space in the name, -e.g. if trying to refer to a page from a [.mld] file "1.2.3.mld". In this case, the +e.g. if trying to refer to a page from a [.mld] file "1.2.3.mld", or to an asset, like a [.txt] file "file.txt". In this case, the element name should be quoted with double quote marks: {v -{!page-"1.2.3"} +{!page-"1.2.3"}, {!asset-"file.txt"} v} diff --git a/doc/parent_child_spec.mld b/doc/parent_child_spec.mld index ec76c03400..a8814eba3e 100644 --- a/doc/parent_child_spec.mld +++ b/doc/parent_child_spec.mld @@ -175,9 +175,9 @@ installed and might be used by a different driver. In order for drivers to build consistent documentation for a package, the following convention should be followed. -- [.mld] pages are installed in a package's [share] directory, under the - [odoc-pages] sub-directory. -- A page is the parent of every installed pages. The driver can freely name this +- [.mld] pages and assets are installed in a package's [doc] directory, under the + [odoc-pages] sub-directory. This means that assets with the `.mld` extension are recognized as pages. +- A page is the parent of every installed pages and assets. The driver can freely name this page, for example it can be named after the package. In what follows, we refer to this page as the [pkg] page. - If there is an installed [index.mld] file, the driver has to use it as @@ -185,7 +185,7 @@ following convention should be followed. - If there is no installed [index.mld] page, the driver has to generate some content for the [pkg] page. -This convention is followed by the +This convention (excluding assets) is followed by the {{:https://github.com/ocaml-doc/voodoo}driver for ocaml.org}, by the driver {{:https://erratique.ch/software/odig/doc/packaging.html}Odig} and by the build system {{:https://github.com/ocaml/dune}Dune}. diff --git a/src/document/comment.ml b/src/document/comment.ml index 5fc683423d..018a9ae361 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -88,6 +88,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 = diff --git a/src/model/names.ml b/src/model/names.ml index 9ae4701b2c..ddcd350902 100644 --- a/src/model/names.ml +++ b/src/model/names.ml @@ -138,3 +138,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 index 7854988977..c13d16e99d 100644 --- a/src/model/names.mli +++ b/src/model/names.mli @@ -101,3 +101,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 index f2d814d698..13079dd417 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -1058,6 +1058,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 @@ -1143,4 +1147,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 diff --git a/src/model/paths.mli b/src/model/paths.mli index 2105b8b210..1e1021b6c7 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -546,6 +546,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 @@ -631,6 +635,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 diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index bf306203d4..5de2691089 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -310,6 +310,8 @@ module Identifier = struct type reference_label = label type reference_page = page + + type reference_asset = asset_file end module rec Path : sig @@ -548,6 +550,7 @@ module rec Reference : sig | `TInstanceVariable | `TLabel | `TPage + | `TAsset | `TChildPage | `TChildModule | `TUnknown ] @@ -720,9 +723,7 @@ module rec Reference : sig (** @canonical Odoc_model.Paths.Reference.Label.t *) type page = - [ `Resolved of Resolved_reference.page - | `Root of string * [ `TPage | `TUnknown ] - | `Dot of label_parent * string ] + [ `Root of string * [ `TPage | `TUnknown ] | `Dot of label_parent * string ] (** @canonical Odoc_model.Paths.Reference.Page.t *) type any = @@ -742,8 +743,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 @@ -908,5 +917,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 diff --git a/src/model/reference.ml b/src/model/reference.ml index 1f9b98c5a6..07cd1867ee 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -15,16 +15,11 @@ let should_not_be_empty : what:string -> Location_.span -> Error.t = fun ~what -> Error.make "%s should not be empty." (Astring.String.Ascii.capitalize what) -let not_allowed : - ?suggestion:string -> - what:string -> - in_what:string -> - Location_.span -> - Error.t = - fun ?suggestion ~what ~in_what -> - Error.make ?suggestion "%s is not allowed in %s." +let should_be_first : + ?suggestion:string -> what:string -> Location_.span -> Error.t = + fun ?suggestion ~what -> + Error.make ?suggestion "%s is not allowed to have a parent." (Astring.String.Ascii.capitalize what) - in_what let deprecated_reference_kind location kind replacement = deprecated_reference_kind kind replacement location |> Error.raise_warning @@ -76,6 +71,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 @@ -298,6 +294,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) + | _ :: _ -> ( + match kind with + | (`TUnknown | `TPage) as k -> + let suggestion = + match k with + | `TUnknown -> Printf.sprintf "'%s' should be first." identifier + | `TPage -> Printf.sprintf "'page-%s' should be first." identifier + in + should_be_first ~what:"Page label" ~suggestion location + |> Error.raise_exception + | _ -> expected [ "page" ] 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 = @@ -363,21 +379,19 @@ 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 in - not_allowed ~what:"Child label" - ~in_what:"the last component of a reference path" ~suggestion - location + should_be_first ~what:"Child label" ~suggestion location |> Error.raise_exception | `TPage -> 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 + should_be_first ~what:"Page label" ~suggestion location |> Error.raise_exception) in diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 03b0d816ca..10adb778c4 100644 --- a/src/model_desc/paths_desc.ml +++ b/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 @@ -200,6 +202,7 @@ module General_paths = struct | `TType -> C0 "`TType" | `TUnknown -> C0 "`TUnknown" | `TValue -> C0 "`TValue" + | `TAsset -> C0 "`TAsset" | `TChildPage -> C0 "`TChildPage" | `TChildModule -> C0 "`TChildModule") @@ -329,7 +332,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 diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 6406a9c76a..201c37afd2 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -527,6 +527,8 @@ module Element = struct (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] + type asset = [ `Asset of Identifier.AssetFile.t ] + type label_parent = [ signature | type_ | page ] type fragment_type_parent = [ signature | datatype ] @@ -543,7 +545,8 @@ module Element = struct | extension | extension_decl | field - | page ] + | page + | asset ] let identifier : [< any ] -> Odoc_model.Paths.Identifier.t = let open Odoc_model.Paths.Identifier in @@ -561,6 +564,7 @@ module Element = struct | `Extension (id, _, _) -> (id :> t) | `ExtensionDecl (id, _) -> (id :> t) | `Page (id, _) -> (id :> t) + | `Asset id -> (id :> t) end module Fmt = struct @@ -1499,6 +1503,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 @@ -1562,6 +1571,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 diff --git a/src/xref2/component.mli b/src/xref2/component.mli index beb42738c0..307431a924 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -491,6 +491,8 @@ module Element : sig (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] + type asset = [ `Asset of Identifier.AssetFile.t ] + type label_parent = [ signature | type_ | page ] type fragment_type_parent = [ signature | datatype ] @@ -507,7 +509,8 @@ module Element : sig | extension | extension_decl | field - | page ] + | page + | asset ] val identifier : [< any ] -> Identifier.t end @@ -636,7 +639,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 diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 73de06de0b..73997a9ebe 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -84,6 +84,7 @@ type kind = | Kind_Exception | Kind_Extension | Kind_Field + | Kind_Asset module ElementsByName : sig type t @@ -356,6 +357,10 @@ let add_extension_constructor identifier add_to_elts Kind_Extension identifier (`Extension (identifier, ec, te)) env |> add_cdocs identifier ec.doc +let add_asset identifier env = + if env.linking then add_to_elts Kind_Asset identifier (`Asset identifier) env + else env + let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = fun unit -> let id = (unit.id :> Paths.Identifier.Module.t) in @@ -595,6 +600,9 @@ let s_fragment_type_parent : Component.Element.fragment_type_parent scope = | #Component.Element.fragment_type_parent as r -> Some r | _ -> None) +let s_asset : Component.Element.asset scope = + make_scope (function #Component.Element.asset as r -> Some r | _ -> None) + let len = ref 0 let n = ref 0 @@ -804,6 +812,29 @@ let open_units resolver env = | _ -> env) env resolver.open_units +let rec collect_assets env (page : Lang.Page.t) = + let env = + match page.name with + | { iv = `Page (Some parent, _); _ } + | { iv = `LeafPage (Some parent, _); _ } -> ( + let parent_name = match parent.iv with `Page (_, name) -> name in + match lookup_page (PageName.to_string parent_name) env with + | None -> env + | Some parent_page -> collect_assets env parent_page) + | _ -> env + in + let env = + List.fold_left + (fun env new_asset -> + let id = Identifier.Mk.asset_file (page.name, new_asset) in + add_asset id env) + env + (Utils.filter_map [] + (function Lang.Page.Asset_child c -> Some c | _ -> None) + page.children) + in + env + let env_of_unit t ~linking resolver = let open Lang.Compilation_unit in let initial_env = @@ -812,13 +843,25 @@ 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 - set_resolver initial_env resolver |> open_units resolver + let initial_env = set_resolver initial_env resolver |> open_units resolver in + let initial_env = + match t.id.iv with + | `Root (None, _) -> initial_env + | `Root (Some parent, _) -> ( + let parent_name = match parent.iv with `Page (_, name) -> name in + match lookup_page (PageName.to_string parent_name) initial_env with + | None -> initial_env + | Some parent_page -> collect_assets initial_env parent_page) + in + initial_env 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 - set_resolver initial_env resolver |> open_units resolver + let initial_env = set_resolver initial_env resolver |> open_units resolver in + let initial_env = collect_assets initial_env page in + initial_env let env_for_reference resolver = set_resolver empty resolver |> open_units resolver diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 8be6e82135..870e775b66 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -146,6 +146,8 @@ val s_label_parent : Component.Element.label_parent scope val s_fragment_type_parent : Component.Element.fragment_type_parent scope +val s_asset : Component.Element.asset scope + (* val open_component_signature : Paths_types.Identifier.signature -> Component.Signature.t -> t -> t *) diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index f5044308be..77a03d0efe 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -9,7 +9,17 @@ 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 *) @@ -127,6 +137,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 @@ -312,7 +324,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 = @@ -362,6 +375,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 diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 850f82982f..e3102f2741 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -74,6 +74,7 @@ let ref_kind_of_element = function | `ExtensionDecl _ -> "extension-decl" | `Field _ -> "field" | `Page _ -> "page" + | `Asset _ -> "asset" let ref_kind_of_find = function | `FModule _ | `FModule_subst _ -> "module" @@ -354,7 +355,7 @@ module L = struct when name = LabelName.to_string name' -> Ok (`Identifier label) | _ -> find tl) - | [] -> Error (`Find_by_name (`Page, name)) + | [] -> Error (`Find_by_name (`Label, name)) in find p.Odoc_model.Lang.Page.content @@ -569,9 +570,48 @@ module Page = struct | Some p -> Ok (`Identifier p.Odoc_model.Lang.Page.name, p) | None -> Error (`Lookup_by_name (`Page, name)) + let in_env_from_id env (id : Identifier.Page.t) = + match id with + | { iv = `Page (_, parent_name) | `LeafPage (_, parent_name); _ } -> + in_env env (PageName.to_string parent_name) + let of_element _env (`Page (id, page)) : t = (`Identifier id, page) end +module A = struct + (** Assets *) + + let in_env env name = + env_lookup_by_name ~kind:`Asset Env.s_asset name env >>= fun (`Asset id) -> + Ok (`Identifier id) + + let rec in_page env (page : Odoc_model.Lang.Page.t) (asset_name : string) : + (Reference.Resolved.Asset.t, _) result = + let has_asset children asset = + List.exists + (function + | Odoc_model.Lang.Page.Asset_child a -> a = asset | _ -> false) + children + in + let parent_id + { + Odoc_model.Lang.Page.name = + { iv = `Page (parent, _) | `LeafPage (parent, _); _ }; + _; + } = + parent + in + if has_asset page.children asset_name then + Ok (`Identifier (Identifier.Mk.asset_file (page.name, asset_name))) + else + let parent = (parent_id page :> Identifier.Page.t option) in + match parent with + | Some parent -> + Page.in_env_from_id env parent >>= fun (_, p) -> + in_page env p asset_name + | None -> Error (`Lookup_by_name (`Asset, asset_name)) +end + module LP = struct (** Label parent *) @@ -784,7 +824,12 @@ let resolve_reference_dot_sg env ~parent_path ~parent_ref ~parent_sg name = Error (`Find_by_name (`Any, name)) let resolve_reference_dot_page env page name = - L.in_page env page name >>= resolved1 + match (L.in_page env page name, page) with + | Ok e, _ -> resolved1 e + | Error _, `P (_, p) -> ( + match A.in_page env p name with + | Ok e -> resolved1 e + | Error _ -> Error (`Find_by_name (`Asset_or_label, name))) let resolve_reference_dot_type env ~parent_ref t name = find Find.any_in_type t name >>= function @@ -806,10 +851,28 @@ 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 `Dot (_, name) | `Root (name, _) -> Page.in_env env name + +let resolve_asset_reference env (m : Reference.Asset.t) = + match m with + | `Resolved r -> Ok r + | `Root (name, _) -> A.in_env env name + | `Dot (parent, name) -> + let x = + resolve_label_parent_reference env parent >>= function + | (`S _ | `T _ | `C _ | `CT _) as c -> wrong_kind_error [ `Page ] c + | `P _ as page -> Ok page + in + x >>= fun (`P (_, p)) -> A.in_page env p name + | `Asset (parent_page, name) -> + resolve_page_reference env parent_page >>= fun (_, p) -> + A.in_page env 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 @@ -826,7 +889,8 @@ let resolve_reference = | `Extension (id, _, _) -> identifier id | `ExtensionDecl (id, _) -> identifier id | `Field (id, _) -> identifier id - | `Page (id, _) -> identifier id) + | `Page (id, _) -> identifier id + | `Asset id -> identifier id) | `Resolved r -> Ok r | `Root (name, (`TModule | `TChildModule)) -> M.in_env env name >>= resolved | `Module (parent, name) -> @@ -885,6 +949,8 @@ 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 >>= resolved1 | `InstanceVariable (parent, name) -> resolve_class_signature_reference env parent >>= fun p -> MV.in_class_signature env p name >>= resolved1 @@ -892,5 +958,10 @@ let resolve_reference = 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_asset_reference env m = + Odoc_model.Error.catch_warnings (fun () -> resolve_asset_reference env m) diff --git a/src/xref2/ref_tools.mli b/src/xref2/ref_tools.mli index c6608379e1..ba2a0eb275 100644 --- a/src/xref2/ref_tools.mli +++ b/src/xref2/ref_tools.mli @@ -13,3 +13,6 @@ val resolve_module_reference : val resolve_reference : Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings + +val resolve_asset_reference : + Env.t -> Asset.t -> Resolved.Asset.t ref_result Odoc_model.Error.with_warnings diff --git a/test/model/semantics/test.ml b/test/model/semantics/test.ml index 5460e18824..66dc00599e 100644 --- a/test/model/semantics/test.ml +++ b/test/model/semantics/test.ml @@ -2353,7 +2353,7 @@ let%expect_test _ = test "{!foo.page-bar}"; [%expect {| - {"value":[{"`Paragraph":[{"`Code_span":"foo.page-bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-14:\nPage label is not allowed in the last component of a reference path.\nSuggestion: 'page-bar' should be first."]} |}] + {"value":[{"`Paragraph":[{"`Code_span":"foo.page-bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-14:\nPage label is not allowed to have a parent.\nSuggestion: 'page-bar' should be first."]} |}] let inner_parent_something_in_something = test "{!foo.bar.field-baz}"; diff --git a/test/xref2/references_to_assets.t/index.mld b/test/xref2/references_to_assets.t/index.mld new file mode 100644 index 0000000000..d887683abd --- /dev/null +++ b/test/xref2/references_to_assets.t/index.mld @@ -0,0 +1,10 @@ +{0 Package page} + +A {{!asset-"caml.gif"}reference} to an asset. + +And a reference using a page parent, with various qualifications: +- {!page-other_page.asset-"caml_not.gif"} +- {!page-other_page."caml_not.gif"} +- {!other_page."caml_not.gif"} +- {!other_page.asset-"caml_not.gif"} +- {!"caml.gif"} \ No newline at end of file diff --git a/test/xref2/references_to_assets.t/other_page.mld b/test/xref2/references_to_assets.t/other_page.mld new file mode 100644 index 0000000000..0849b3015b --- /dev/null +++ b/test/xref2/references_to_assets.t/other_page.mld @@ -0,0 +1,3 @@ +{0 Another page with an asset} + +Hello darkness my old {!asset-"caml.gif"}. \ No newline at end of file diff --git a/test/xref2/references_to_assets.t/run.t b/test/xref2/references_to_assets.t/run.t new file mode 100644 index 0000000000..cf0d9a8e40 --- /dev/null +++ b/test/xref2/references_to_assets.t/run.t @@ -0,0 +1,77 @@ +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 caml.gif) +- in a parent page (test.mli references caml.gif) +- in a sibling page (test.mli references caml_not.gif, through page-other_page.caml_not.gif) +- in a child page (index.mld references caml_not.gif, through page-other_page.caml_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 + $ odoc link -I . test.odoc + File "test.mli", line 5, 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 3, characters 4-34: + Warning: Failed to resolve reference unresolvedroot(caml.gif) Couldn't find asset "caml.gif" + $ odoc link -I . page-index.odoc + File "index.mld", line 10, characters 2-15: + Warning: Failed to resolve reference unresolvedroot(caml.gif) Couldn't find "caml.gif" + File "index.mld", line 9, characters 2-36: + Warning: Failed to resolve reference unresolvedroot(other_page).caml_not.gif Couldn't find asset "caml_not.gif" + File "index.mld", line 8, characters 2-30: + Warning: Failed to resolve reference unresolvedroot(other_page).caml_not.gif Couldn't find asset or label "caml_not.gif" + File "index.mld", line 7, characters 2-35: + Warning: Failed to resolve reference unresolvedroot(other_page).caml_not.gif Couldn't find asset or label "caml_not.gif" + File "index.mld", line 6, characters 2-41: + 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" + $ odoc link -I . page-other_page.odoc + File "other_page.mld", line 3, characters 22-41: + 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: + + $ for i in *.odoc; do odoc link -I . $i; done + + $ touch caml.gif + $ touch caml_not.gif + $ odoc html-generate --asset=caml.gif --indent page-index.odocl -o html + $ odoc html-generate --asset=caml_not.gif --indent page-other_page.odocl -o html + $ odoc html-generate --indent test.odocl -o html + +Note that the html links are correct + + $ find html -name caml.gif + html/index/caml.gif + $ find html -name caml_not.gif + html/index/other_page/caml_not.gif + + $ grep caml.gif html/index/index.html +
A reference to an asset.
+caml.gif
caml_not.gif
caml_not.gif
caml_not.gif
caml_not.gif
A reference to an asset
+ $ grep caml_not.gif html/index/Test/index.html
+ caml_not.gif
+ $ grep caml.gif html/index/other_page/index.html
+
Hello darkness my old caml.gif
.
diff --git a/test/xref2/references_to_assets.t/test.mli b/test/xref2/references_to_assets.t/test.mli
new file mode 100644
index 0000000000..5d8d37b1a5
--- /dev/null
+++ b/test/xref2/references_to_assets.t/test.mli
@@ -0,0 +1,6 @@
+val x : int
+(**
+ A {{!asset-"caml.gif"}reference} to an asset
+
+ And a reference using a page parent: {!page-other_page.asset-"caml_not.gif"}
+ *)
diff --git a/test/xref2/references_to_pages.t/run.t b/test/xref2/references_to_pages.t/run.t
index 0b9c36cecf..d8b7f3614c 100644
--- a/test/xref2/references_to_pages.t/run.t
+++ b/test/xref2/references_to_pages.t/run.t
@@ -2,7 +2,7 @@
$ compile p.mld good_references.mli bad_references.mli
File "bad_references.mli", line 6, characters 42-69:
- Warning: Failed to resolve reference unresolvedroot(p).not_found Couldn't find page "not_found"
+ Warning: Failed to resolve reference unresolvedroot(p).not_found Couldn't find label "not_found"
File "bad_references.mli", line 4, characters 20-37:
Warning: Failed to resolve reference unresolvedroot(not_found) Couldn't find page "not_found"