Rudimentary support for assets

src/document/renderer.ml

@@ -17,14 +17,14 @@ let traverse ~f t =
   in
   List.iter aux t
 
+type input =
+  | CU of Odoc_model.Lang.Compilation_unit.t
+  | Page of Odoc_model.Lang.Page.t
+
 type 'a t = {
   name : string;
   render : 'a -> Types.Document.t -> page list;
-  extra_documents :
-    'a ->
-    Odoc_model.Lang.Compilation_unit.t ->
-    syntax:syntax ->
-    Types.Document.t list;
+  extra_documents : 'a -> input -> syntax:syntax -> Types.Document.t list;
 }
 
 let document_of_page ~syntax v =

src/document/types.ml

@@ -192,8 +192,13 @@ and Source_page : sig
 end =
   Source_page
 
+and Asset : sig
+  type t = { url : Url.Path.t; src : Fpath.t }
+end =
+  Asset
+
 module Document = struct
-  type t = Page of Page.t | Source_page of Source_page.t
+  type t = Page of Page.t | Source_page of Source_page.t | Asset of Asset.t
 end
 
 let inline ?(attr = []) desc = Inline.{ attr; desc }

src/document/url.ml

@@ -87,10 +87,13 @@ module Path = struct
     | Identifier.Signature.t_pv
     | Identifier.ClassSignature.t_pv ]
 
-  type source_pv =
-    [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.SourceDir.t_pv ]
+  type any_pv =
+    [ nonsrc_pv
+    | Identifier.SourcePage.t_pv
+    | Identifier.SourceDir.t_pv
+    | Identifier.AssetFile.t_pv ]
 
-  and source = source_pv Odoc_model.Paths.Identifier.id
+  and any = any_pv Odoc_model.Paths.Identifier.id
 
   type kind =
     [ `Module
@@ -120,13 +123,13 @@ module Path = struct
 
   let mk ?parent kind name = { kind; parent; name }
 
-  let rec from_identifier : source -> t =
+  let rec from_identifier : any -> t =
    fun x ->
     match x with
     | { iv = `Root (parent, unit_name); _ } ->
         let parent =
           match parent with
-          | Some p -> Some (from_identifier (p :> source))
+          | Some p -> Some (from_identifier (p :> any))
           | None -> None
         in
         let kind = `Module in
@@ -135,7 +138,7 @@ module Path = struct
     | { iv = `Page (parent, page_name); _ } ->
         let parent =
           match parent with
-          | Some p -> Some (from_identifier (p :> source))
+          | Some p -> Some (from_identifier (p :> any))
           | None -> None
         in
         let kind = `Page in
@@ -144,48 +147,51 @@ module Path = struct
     | { iv = `LeafPage (parent, page_name); _ } ->
         let parent =
           match parent with
-          | Some p -> Some (from_identifier (p :> source))
+          | Some p -> Some (from_identifier (p :> any))
           | None -> None
         in
         let kind = `LeafPage in
         let name = PageName.to_string page_name in
         mk ?parent kind name
     | { iv = `Module (parent, mod_name); _ } ->
-        let parent = from_identifier (parent :> source) in
+        let parent = from_identifier (parent :> any) in
         let kind = `Module in
         let name = ModuleName.to_string mod_name in
         mk ~parent kind name
     | { iv = `Parameter (functor_id, arg_name); _ } as p ->
-        let parent = from_identifier (functor_id :> source) in
+        let parent = from_identifier (functor_id :> any) in
         let arg_num = functor_arg_pos p in
         let kind = `Parameter arg_num in
         let name = ModuleName.to_string arg_name in
         mk ~parent kind name
     | { iv = `ModuleType (parent, modt_name); _ } ->
-        let parent = from_identifier (parent :> source) in
+        let parent = from_identifier (parent :> any) in
         let kind = `ModuleType in
         let name = ModuleTypeName.to_string modt_name in
         mk ~parent kind name
     | { iv = `Class (parent, name); _ } ->
-        let parent = from_identifier (parent :> source) in
+        let parent = from_identifier (parent :> any) in
         let kind = `Class in
         let name = ClassName.to_string name in
         mk ~parent kind name
     | { iv = `ClassType (parent, name); _ } ->
-        let parent = from_identifier (parent :> source) in
+        let parent = from_identifier (parent :> any) in
         let kind = `ClassType in
         let name = ClassTypeName.to_string name in
         mk ~parent kind name
-    | { iv = `Result p; _ } -> from_identifier (p :> source)
+    | { iv = `Result p; _ } -> from_identifier (p :> any)
     | { iv = `SourceDir (parent, name); _ }
     | { iv = `SourcePage (parent, name); _ } ->
-        let parent = from_identifier (parent :> source) in
+        let parent = from_identifier (parent :> any) in
         let kind = `Page in
         mk ~parent kind name
+    | { iv = `AssetFile (parent, name); _ } ->
+        let parent = from_identifier (parent :> any) in
+        let kind = `File in
+        mk ~parent kind name
 
   let from_identifier p =
-    from_identifier
-      (p : [< source_pv ] Odoc_model.Paths.Identifier.id :> source)
+    from_identifier (p : [< any_pv ] Odoc_model.Paths.Identifier.id :> any)
 
   let to_list url =
     let rec loop acc { parent; name; kind } =
@@ -266,21 +272,21 @@ module Anchor = struct
     let open Error in
     function
     | { iv = `Module (parent, mod_name); _ } ->
-        let parent = Path.from_identifier (parent :> Path.source) in
+        let parent = Path.from_identifier (parent :> Path.any) in
         let kind = `Module in
         let anchor =
           Printf.sprintf "%s-%s" (Path.string_of_kind kind)
             (ModuleName.to_string mod_name)
         in
         Ok { page = parent; anchor; kind }
     | { iv = `Root _; _ } as p ->
-        let page = Path.from_identifier (p :> Path.source) in
+        let page = Path.from_identifier (p :> Path.any) in
         Ok { page; kind = `Module; anchor = "" }
     | { iv = `Page _; _ } as p ->
-        let page = Path.from_identifier (p :> Path.source) in
+        let page = Path.from_identifier (p :> Path.any) in
         Ok { page; kind = `Page; anchor = "" }
     | { iv = `LeafPage _; _ } as p ->
-        let page = Path.from_identifier (p :> Path.source) in
+        let page = Path.from_identifier (p :> Path.any) in
         Ok { page; kind = `LeafPage; anchor = "" }
     (* For all these identifiers, page names and anchors are the same *)
     | {
@@ -289,7 +295,7 @@ module Anchor = struct
       } as p ->
         Ok (anchorify_path @@ Path.from_identifier p)
     | { iv = `Type (parent, type_name); _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Type in
         Ok
           {
@@ -302,7 +308,7 @@ module Anchor = struct
     | { iv = `CoreType ty_name; _ } ->
         Error (Not_linkable ("core_type:" ^ TypeName.to_string ty_name))
     | { iv = `Extension (parent, name); _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Extension in
         Ok
           {
@@ -313,7 +319,7 @@ module Anchor = struct
             kind;
           }
     | { iv = `Exception (parent, name); _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Exception in
         Ok
           {
@@ -326,7 +332,7 @@ module Anchor = struct
     | { iv = `CoreException name; _ } ->
         Error (Not_linkable ("core_exception:" ^ ExceptionName.to_string name))
     | { iv = `Value (parent, name); _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Val in
         Ok
           {
@@ -337,13 +343,13 @@ module Anchor = struct
           }
     | { iv = `Method (parent, name); _ } ->
         let str_name = MethodName.to_string name in
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Method in
         Ok
           { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }
     | { iv = `InstanceVariable (parent, name); _ } ->
         let str_name = InstanceVariableName.to_string name in
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Val in
         Ok
           { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }
@@ -367,16 +373,19 @@ module Anchor = struct
             Error (Unexpected_anchor "core_type label parent")
         | { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name
         | { iv = #Path.nonsrc_pv; _ } as p ->
-            mk ~kind:`Section (p :> Path.source) str_name)
+            mk ~kind:`Section (p :> Path.any) str_name)
     | { iv = `SourceLocation (parent, loc); _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         Ok { page; kind = `SourceAnchor; anchor = DefName.to_string loc }
     | { iv = `SourceLocationMod parent; _ } ->
-        let page = Path.from_identifier (parent :> Path.source) in
+        let page = Path.from_identifier (parent :> Path.any) in
         Ok { page; kind = `SourceAnchor; anchor = "" }
-    | { iv = `SourcePage (p, _name); _ } | { iv = `SourceDir (p, _name); _ } ->
-        let page = Path.from_identifier (p :> Path.source) in
+    | { iv = `SourcePage _ | `SourceDir _; _ } as p ->
+        let page = Path.from_identifier (p :> Path.any) in
         Ok { page; kind = `Page; anchor = "" }
+    | { iv = `AssetFile _; _ } as p ->
+        let page = Path.from_identifier p in
+        Ok { page; kind = `File; anchor = "" }
 
   let polymorphic_variant ~type_ident elt =
     let name_of_type_constr te =
@@ -403,7 +412,7 @@ module Anchor = struct
   (** The anchor looks like
       [extension-decl-"Path.target_type"-FirstConstructor]. *)
   let extension_decl (decl : Odoc_model.Lang.Extension.t) =
-    let page = Path.from_identifier (decl.parent :> Path.source) in
+    let page = Path.from_identifier (decl.parent :> Path.any) in
     let kind = `ExtensionDecl in
     let first_cons = Identifier.name (List.hd decl.constructors).id in
     let anchor = Format.asprintf "%a-%s" pp_kind kind first_cons in
@@ -420,7 +429,7 @@ let from_path page =
   { Anchor.page; anchor = ""; kind = (page.kind :> Anchor.kind) }
 
 let from_identifier ~stop_before = function
-  | { Odoc_model.Paths.Identifier.iv = #Path.source_pv; _ } as p
+  | { Odoc_model.Paths.Identifier.iv = #Path.any_pv; _ } as p
     when not stop_before ->
       Ok (from_path @@ Path.from_identifier p)
   | p -> Anchor.from_identifier p

src/document/url.mli

@@ -29,17 +29,17 @@ module Path : sig
 
   type t = { kind : kind; parent : t option; name : string }
 
-  type nonsrc_pv =
+  type any_pv =
     [ Identifier.Page.t_pv
     | Identifier.Signature.t_pv
-    | Identifier.ClassSignature.t_pv ]
+    | Identifier.ClassSignature.t_pv
+    | Identifier.SourcePage.t_pv
+    | Identifier.SourceDir.t_pv
+    | Identifier.AssetFile.t_pv ]
 
-  type source_pv =
-    [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.SourceDir.t_pv ]
+  and any = any_pv Odoc_model.Paths.Identifier.id
 
-  and source = source_pv Odoc_model.Paths.Identifier.id
-
-  val from_identifier : [< source_pv ] Odoc_model.Paths.Identifier.id -> t
+  val from_identifier : [< any_pv ] Odoc_model.Paths.Identifier.id -> t
 
   val to_list : t -> (kind * string) list
 

src/html/generator.ml

@@ -503,11 +503,32 @@ module Page = struct
     if Config.as_json config then
       Html_fragment_json.make_src ~config ~url ~breadcrumbs [ doc ]
     else Html_page.make_src ~breadcrumbs ~header ~config ~url title [ doc ]
+
+  let asset ~config { Asset.url; src } =
+    let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+    let content ppf =
+      let ic = open_in_bin (Fpath.to_string src) in
+      let len = 1024 in
+      let buf = Bytes.create len in
+      let rec loop () =
+        let read = input ic buf 0 len in
+        if read = len then (
+          Format.fprintf ppf "%s" (Bytes.to_string buf);
+          loop ())
+        else if len > 0 then
+          let buf = Bytes.sub buf 0 read in
+          Format.fprintf ppf "%s" (Bytes.to_string buf)
+      in
+      loop ();
+      close_in ic
+    in
+    { Odoc_document.Renderer.filename; content; children = [] }
 end
 
 let render ~config = function
   | Document.Page page -> [ Page.page ~config page ]
   | Source_page src -> [ Page.source_page ~config src ]
+  | Asset asset -> [ Page.asset ~config asset ]
 
 let doc ~config ~xref_base_uri b =
   let resolve = Link.Base xref_base_uri in

src/latex/generator.ml

@@ -489,4 +489,4 @@ end
 
 let render ~with_children = function
   | Document.Page page -> [ Page.page ~with_children page ]
-  | Source_page _ -> []
+  | Source_page _ | Asset _ -> []

src/manpage/generator.ml

@@ -562,4 +562,4 @@ and render_page (p : Page.t) =
 
 let render = function
   | Document.Page page -> [ render_page page ]
-  | Source_page _ -> []
+  | Source_page _ | Asset _ -> []

src/model/lang.ml

@@ -497,6 +497,7 @@ module rec Page : sig
     | Page_child of string
     | Module_child of string
     | Source_tree_child of string
+    | Asset_child of string
 
   type t = {
     name : Identifier.Page.t;

src/model/paths.ml

@@ -55,6 +55,7 @@ module Identifier = struct
     | `SourceDir (_, name) -> name
     | `SourceLocation (_, anchor) -> DefName.to_string anchor
     | `SourceLocationMod x -> name_aux (x :> t)
+    | `AssetFile (_, name) -> name
 
   let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t)
 
@@ -282,6 +283,11 @@ module Identifier = struct
     type t_pv = Paths_types.Identifier.source_location_pv
   end
 
+  module AssetFile = struct
+    type t = Id.asset_file
+    type t_pv = Id.asset_file_pv
+  end
+
   module OdocId = struct
     type t = Id.odoc_id
     type t_pv = Id.odoc_id_pv
@@ -372,6 +378,9 @@ 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 source_page (container_page, path) =
       let rec source_dir dir =
         match dir with

src/model/paths.mli

@@ -143,6 +143,11 @@ module Identifier : sig
     type t_pv = Id.source_location_pv
   end
 
+  module AssetFile : sig
+    type t = Id.asset_file
+    type t_pv = Id.asset_file_pv
+  end
+
   module OdocId : sig
     type t = Id.odoc_id
     type t_pv = Id.odoc_id_pv
@@ -219,6 +224,8 @@ module Identifier : sig
 
     val source_page : ContainerPage.t * string list -> SourcePage.t
 
+    val asset_file : Page.t * string -> AssetFile.t
+
     val root :
       ContainerPage.t option * ModuleName.t ->
       [> `Root of ContainerPage.t option * ModuleName.t ] id